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
, Qunbound
;
56 static Lisp_Object Qsubr
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qargs_out_of_range
;
59 static Lisp_Object Qwrong_type_argument
;
60 Lisp_Object Qvoid_variable
, Qvoid_function
;
61 static Lisp_Object Qcyclic_function_indirection
;
62 static Lisp_Object Qcyclic_variable_indirection
;
63 Lisp_Object Qcircular_list
;
64 static Lisp_Object Qsetting_constant
;
65 Lisp_Object Qinvalid_read_syntax
;
66 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
67 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
68 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
69 Lisp_Object Qtext_read_only
;
71 Lisp_Object Qintegerp
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
72 static Lisp_Object Qnatnump
;
73 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
74 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
75 Lisp_Object Qbuffer_or_string_p
;
76 static Lisp_Object Qkeywordp
, Qboundp
;
78 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
81 static Lisp_Object Qad_advice_info
, Qad_activate_internal
;
83 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
84 Lisp_Object Qoverflow_error
, Qunderflow_error
;
87 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
90 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
92 static Lisp_Object Qfloat
, Qwindow_configuration
;
93 static Lisp_Object Qprocess
;
94 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
95 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
96 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
97 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
99 Lisp_Object Qinteractive_form
;
101 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
105 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
107 /* If VALUE is not even a valid Lisp object, we'd want to abort here
108 where we can get a backtrace showing where it came from. We used
109 to try and do that by checking the tagbits, but nowadays all
110 tagbits are potentially valid. */
111 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
114 xsignal2 (Qwrong_type_argument
, predicate
, value
);
118 pure_write_error (void)
120 error ("Attempt to modify read-only object");
124 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
126 xsignal2 (Qargs_out_of_range
, a1
, a2
);
130 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
132 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
136 /* Data type predicates */
138 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
139 doc
: /* Return t if the two args are the same Lisp object. */)
140 (Lisp_Object obj1
, Lisp_Object obj2
)
147 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
148 doc
: /* Return t if OBJECT is nil. */)
156 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
157 doc
: /* Return a symbol representing the type of OBJECT.
158 The symbol returned names the object's basic type;
159 for example, (type-of 1) returns `integer'. */)
162 switch (XTYPE (object
))
177 switch (XMISCTYPE (object
))
179 case Lisp_Misc_Marker
:
181 case Lisp_Misc_Overlay
:
183 case Lisp_Misc_Float
:
188 case Lisp_Vectorlike
:
189 if (WINDOW_CONFIGURATIONP (object
))
190 return Qwindow_configuration
;
191 if (PROCESSP (object
))
193 if (WINDOWP (object
))
197 if (COMPILEDP (object
))
198 return Qcompiled_function
;
199 if (BUFFERP (object
))
201 if (CHAR_TABLE_P (object
))
203 if (BOOL_VECTOR_P (object
))
207 if (HASH_TABLE_P (object
))
209 if (FONT_SPEC_P (object
))
211 if (FONT_ENTITY_P (object
))
213 if (FONT_OBJECT_P (object
))
225 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
226 doc
: /* Return t if OBJECT is a cons cell. */)
234 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
235 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
243 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
244 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
245 Otherwise, return nil. */)
248 if (CONSP (object
) || NILP (object
))
253 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
254 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
257 if (CONSP (object
) || NILP (object
))
262 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
263 doc
: /* Return t if OBJECT is a symbol. */)
266 if (SYMBOLP (object
))
271 /* Define this in C to avoid unnecessarily consing up the symbol
273 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
274 doc
: /* Return t if OBJECT is a keyword.
275 This means that it is a symbol with a print name beginning with `:'
276 interned in the initial obarray. */)
280 && SREF (SYMBOL_NAME (object
), 0) == ':'
281 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
286 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
287 doc
: /* Return t if OBJECT is a vector. */)
290 if (VECTORP (object
))
295 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
296 doc
: /* Return t if OBJECT is a string. */)
299 if (STRINGP (object
))
304 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
306 doc
: /* Return t if OBJECT is a multibyte string. */)
309 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
314 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
315 doc
: /* Return t if OBJECT is a char-table. */)
318 if (CHAR_TABLE_P (object
))
323 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
324 Svector_or_char_table_p
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a char-table or vector. */)
328 if (VECTORP (object
) || CHAR_TABLE_P (object
))
333 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is a bool-vector. */)
337 if (BOOL_VECTOR_P (object
))
342 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
343 doc
: /* Return t if OBJECT is an array (string or vector). */)
351 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a sequence (list or array). */)
353 (register Lisp_Object object
)
355 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
360 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
361 doc
: /* Return t if OBJECT is an editor buffer. */)
364 if (BUFFERP (object
))
369 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
373 if (MARKERP (object
))
378 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
379 doc
: /* Return t if OBJECT is a built-in function. */)
387 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
389 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
392 if (COMPILEDP (object
))
397 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is a character or a string. */)
399 (register Lisp_Object object
)
401 if (CHARACTERP (object
) || STRINGP (object
))
406 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is an integer. */)
410 if (INTEGERP (object
))
415 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
416 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
417 (register Lisp_Object object
)
419 if (MARKERP (object
) || INTEGERP (object
))
424 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a nonnegative integer. */)
428 if (NATNUMP (object
))
433 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
434 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
437 if (NUMBERP (object
))
443 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
444 Snumber_or_marker_p
, 1, 1, 0,
445 doc
: /* Return t if OBJECT is a number or a marker. */)
448 if (NUMBERP (object
) || MARKERP (object
))
453 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
454 doc
: /* Return t if OBJECT is a floating point number. */)
463 /* Extract and set components of lists */
465 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
466 doc
: /* Return the car of LIST. If arg is nil, return nil.
467 Error if arg is not nil and not a cons cell. See also `car-safe'.
469 See Info node `(elisp)Cons Cells' for a discussion of related basic
470 Lisp concepts such as car, cdr, cons cell and list. */)
471 (register Lisp_Object list
)
476 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
477 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
480 return CAR_SAFE (object
);
483 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
484 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
485 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
487 See Info node `(elisp)Cons Cells' for a discussion of related basic
488 Lisp concepts such as cdr, car, cons cell and list. */)
489 (register Lisp_Object list
)
494 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
495 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
498 return CDR_SAFE (object
);
501 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
502 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
503 (register Lisp_Object cell
, Lisp_Object newcar
)
507 XSETCAR (cell
, newcar
);
511 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
512 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
513 (register Lisp_Object cell
, Lisp_Object newcdr
)
517 XSETCDR (cell
, newcdr
);
521 /* Extract and set components of symbols */
523 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
524 doc
: /* Return t if SYMBOL's value is not void. */)
525 (register Lisp_Object symbol
)
527 Lisp_Object valcontents
;
528 struct Lisp_Symbol
*sym
;
529 CHECK_SYMBOL (symbol
);
530 sym
= XSYMBOL (symbol
);
533 switch (sym
->redirect
)
535 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
536 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
537 case SYMBOL_LOCALIZED
:
539 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
541 /* In set_internal, we un-forward vars when their value is
546 swap_in_symval_forwarding (sym
, blv
);
547 valcontents
= BLV_VALUE (blv
);
551 case SYMBOL_FORWARDED
:
552 /* In set_internal, we un-forward vars when their value is
558 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
561 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
562 doc
: /* Return t if SYMBOL's function definition is not void. */)
563 (register Lisp_Object symbol
)
565 CHECK_SYMBOL (symbol
);
566 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
569 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
570 doc
: /* Make SYMBOL's value be void.
572 (register Lisp_Object symbol
)
574 CHECK_SYMBOL (symbol
);
575 if (SYMBOL_CONSTANT_P (symbol
))
576 xsignal1 (Qsetting_constant
, symbol
);
577 Fset (symbol
, Qunbound
);
581 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
582 doc
: /* Make SYMBOL's function definition be void.
584 (register Lisp_Object symbol
)
586 CHECK_SYMBOL (symbol
);
587 if (NILP (symbol
) || EQ (symbol
, Qt
))
588 xsignal1 (Qsetting_constant
, symbol
);
589 XSYMBOL (symbol
)->function
= Qunbound
;
593 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
594 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
595 (register Lisp_Object symbol
)
597 CHECK_SYMBOL (symbol
);
598 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
599 return XSYMBOL (symbol
)->function
;
600 xsignal1 (Qvoid_function
, symbol
);
603 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
604 doc
: /* Return SYMBOL's property list. */)
605 (register Lisp_Object symbol
)
607 CHECK_SYMBOL (symbol
);
608 return XSYMBOL (symbol
)->plist
;
611 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
612 doc
: /* Return SYMBOL's name, a string. */)
613 (register Lisp_Object symbol
)
615 register Lisp_Object name
;
617 CHECK_SYMBOL (symbol
);
618 name
= SYMBOL_NAME (symbol
);
622 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
623 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
624 (register Lisp_Object symbol
, Lisp_Object definition
)
626 register Lisp_Object function
;
628 CHECK_SYMBOL (symbol
);
629 if (NILP (symbol
) || EQ (symbol
, Qt
))
630 xsignal1 (Qsetting_constant
, symbol
);
632 function
= XSYMBOL (symbol
)->function
;
634 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
635 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
637 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
638 Fput (symbol
, Qautoload
, XCDR (function
));
640 XSYMBOL (symbol
)->function
= definition
;
641 /* Handle automatic advice activation */
642 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
644 call2 (Qad_activate_internal
, symbol
, Qnil
);
645 definition
= XSYMBOL (symbol
)->function
;
650 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
651 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
652 Associates the function with the current load file, if any.
653 The optional third argument DOCSTRING specifies the documentation string
654 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
655 determined by DEFINITION. */)
656 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
658 CHECK_SYMBOL (symbol
);
659 if (CONSP (XSYMBOL (symbol
)->function
)
660 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
661 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
662 definition
= Ffset (symbol
, definition
);
663 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
664 if (!NILP (docstring
))
665 Fput (symbol
, Qfunction_documentation
, docstring
);
669 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
670 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
671 (register Lisp_Object symbol
, Lisp_Object newplist
)
673 CHECK_SYMBOL (symbol
);
674 XSYMBOL (symbol
)->plist
= newplist
;
678 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
679 doc
: /* Return minimum and maximum number of args allowed for SUBR.
680 SUBR must be a built-in function.
681 The returned value is a pair (MIN . MAX). MIN is the minimum number
682 of args. MAX is the maximum number or the symbol `many', for a
683 function with `&rest' args, or `unevalled' for a special form. */)
686 short minargs
, maxargs
;
688 minargs
= XSUBR (subr
)->min_args
;
689 maxargs
= XSUBR (subr
)->max_args
;
691 return Fcons (make_number (minargs
), Qmany
);
692 else if (maxargs
== UNEVALLED
)
693 return Fcons (make_number (minargs
), Qunevalled
);
695 return Fcons (make_number (minargs
), make_number (maxargs
));
698 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
699 doc
: /* Return name of subroutine SUBR.
700 SUBR must be a built-in function. */)
705 name
= XSUBR (subr
)->symbol_name
;
706 return make_string (name
, strlen (name
));
709 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
710 doc
: /* Return the interactive form of CMD or nil if none.
711 If CMD is not a command, the return value is nil.
712 Value, if non-nil, is a list \(interactive SPEC). */)
715 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
717 if (NILP (fun
) || EQ (fun
, Qunbound
))
720 /* Use an `interactive-form' property if present, analogous to the
721 function-documentation property. */
723 while (SYMBOLP (fun
))
725 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
729 fun
= Fsymbol_function (fun
);
734 const char *spec
= XSUBR (fun
)->intspec
;
736 return list2 (Qinteractive
,
737 (*spec
!= '(') ? build_string (spec
) :
738 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
740 else if (COMPILEDP (fun
))
742 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
743 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
745 else if (CONSP (fun
))
747 Lisp_Object funcar
= XCAR (fun
);
748 if (EQ (funcar
, Qclosure
))
749 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
750 else if (EQ (funcar
, Qlambda
))
751 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
752 else if (EQ (funcar
, Qautoload
))
756 do_autoload (fun
, cmd
);
758 return Finteractive_form (cmd
);
765 /***********************************************************************
766 Getting and Setting Values of Symbols
767 ***********************************************************************/
769 /* Return the symbol holding SYMBOL's value. Signal
770 `cyclic-variable-indirection' if SYMBOL's chain of variable
771 indirections contains a loop. */
774 indirect_variable (struct Lisp_Symbol
*symbol
)
776 struct Lisp_Symbol
*tortoise
, *hare
;
778 hare
= tortoise
= symbol
;
780 while (hare
->redirect
== SYMBOL_VARALIAS
)
782 hare
= SYMBOL_ALIAS (hare
);
783 if (hare
->redirect
!= SYMBOL_VARALIAS
)
786 hare
= SYMBOL_ALIAS (hare
);
787 tortoise
= SYMBOL_ALIAS (tortoise
);
789 if (hare
== tortoise
)
792 XSETSYMBOL (tem
, symbol
);
793 xsignal1 (Qcyclic_variable_indirection
, tem
);
801 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
802 doc
: /* Return the variable at the end of OBJECT's variable chain.
803 If OBJECT is a symbol, follow all variable indirections and return the final
804 variable. If OBJECT is not a symbol, just return it.
805 Signal a cyclic-variable-indirection error if there is a loop in the
806 variable chain of symbols. */)
809 if (SYMBOLP (object
))
811 struct Lisp_Symbol
*sym
= indirect_variable (XSYMBOL (object
));
812 XSETSYMBOL (object
, sym
);
818 /* Given the raw contents of a symbol value cell,
819 return the Lisp value of the symbol.
820 This does not handle buffer-local variables; use
821 swap_in_symval_forwarding for that. */
824 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
826 register Lisp_Object val
;
827 switch (XFWDTYPE (valcontents
))
830 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
834 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
837 return *XOBJFWD (valcontents
)->objvar
;
839 case Lisp_Fwd_Buffer_Obj
:
840 return PER_BUFFER_VALUE (current_buffer
,
841 XBUFFER_OBJFWD (valcontents
)->offset
);
843 case Lisp_Fwd_Kboard_Obj
:
844 /* We used to simply use current_kboard here, but from Lisp
845 code, it's value is often unexpected. It seems nicer to
846 allow constructions like this to work as intuitively expected:
848 (with-selected-frame frame
849 (define-key local-function-map "\eOP" [f1]))
851 On the other hand, this affects the semantics of
852 last-command and real-last-command, and people may rely on
853 that. I took a quick look at the Lisp codebase, and I
854 don't think anything will break. --lorentey */
855 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
856 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
861 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
862 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
863 buffer-independent contents of the value cell: forwarded just one
864 step past the buffer-localness.
866 BUF non-zero means set the value in buffer BUF instead of the
867 current buffer. This only plays a role for per-buffer variables. */
870 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
872 switch (XFWDTYPE (valcontents
))
875 CHECK_NUMBER (newval
);
876 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
880 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
884 *XOBJFWD (valcontents
)->objvar
= newval
;
886 /* If this variable is a default for something stored
887 in the buffer itself, such as default-fill-column,
888 find the buffers that don't have local values for it
890 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
891 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
893 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
894 - (char *) &buffer_defaults
);
895 int idx
= PER_BUFFER_IDX (offset
);
902 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
907 lbuf
= Fcdr (XCAR (tail
));
908 if (!BUFFERP (lbuf
)) continue;
911 if (! PER_BUFFER_VALUE_P (b
, idx
))
912 PER_BUFFER_VALUE (b
, offset
) = newval
;
917 case Lisp_Fwd_Buffer_Obj
:
919 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
920 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
922 if (!(NILP (type
) || NILP (newval
)
923 || (XINT (type
) == LISP_INT_TAG
925 : XTYPE (newval
) == XINT (type
))))
926 buffer_slot_type_mismatch (newval
, XINT (type
));
929 buf
= current_buffer
;
930 PER_BUFFER_VALUE (buf
, offset
) = newval
;
934 case Lisp_Fwd_Kboard_Obj
:
936 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
937 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
938 *(Lisp_Object
*) p
= newval
;
943 abort (); /* goto def; */
947 /* Set up SYMBOL to refer to its global binding.
948 This makes it safe to alter the status of other bindings. */
951 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
953 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
955 /* Unload the previously loaded binding. */
957 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
959 /* Select the global binding in the symbol. */
960 blv
->valcell
= blv
->defcell
;
962 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
964 /* Indicate that the global binding is set up now. */
966 SET_BLV_FOUND (blv
, 0);
969 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
970 VALCONTENTS is the contents of its value cell,
971 which points to a struct Lisp_Buffer_Local_Value.
973 Return the value forwarded one step past the buffer-local stage.
974 This could be another forwarding pointer. */
977 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
979 register Lisp_Object tem1
;
981 eassert (blv
== SYMBOL_BLV (symbol
));
987 ? !EQ (selected_frame
, tem1
)
988 : current_buffer
!= XBUFFER (tem1
)))
991 /* Unload the previously loaded binding. */
994 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
995 /* Choose the new binding. */
998 XSETSYMBOL (var
, symbol
);
999 if (blv
->frame_local
)
1001 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1002 blv
->where
= selected_frame
;
1006 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1007 XSETBUFFER (blv
->where
, current_buffer
);
1010 if (!(blv
->found
= !NILP (tem1
)))
1011 tem1
= blv
->defcell
;
1013 /* Load the new binding. */
1014 blv
->valcell
= tem1
;
1016 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1020 /* Find the value of a symbol, returning Qunbound if it's not bound.
1021 This is helpful for code which just wants to get a variable's value
1022 if it has one, without signaling an error.
1023 Note that it must not be possible to quit
1024 within this function. Great care is required for this. */
1027 find_symbol_value (Lisp_Object symbol
)
1029 struct Lisp_Symbol
*sym
;
1031 CHECK_SYMBOL (symbol
);
1032 sym
= XSYMBOL (symbol
);
1035 switch (sym
->redirect
)
1037 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1038 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1039 case SYMBOL_LOCALIZED
:
1041 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1042 swap_in_symval_forwarding (sym
, blv
);
1043 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1046 case SYMBOL_FORWARDED
:
1047 return do_symval_forwarding (SYMBOL_FWD (sym
));
1052 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1053 doc
: /* Return SYMBOL's value. Error if that is void. */)
1054 (Lisp_Object symbol
)
1058 val
= find_symbol_value (symbol
);
1059 if (!EQ (val
, Qunbound
))
1062 xsignal1 (Qvoid_variable
, symbol
);
1065 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1066 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1067 (register Lisp_Object symbol
, Lisp_Object newval
)
1069 set_internal (symbol
, newval
, Qnil
, 0);
1073 /* Return 1 if SYMBOL currently has a let-binding
1074 which was made in the buffer that is now current. */
1077 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1079 struct specbinding
*p
;
1081 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1083 && CONSP (p
->symbol
))
1085 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1086 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1087 if (symbol
== let_bound_symbol
1088 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1092 return p
>= specpdl
;
1096 let_shadows_global_binding_p (Lisp_Object symbol
)
1098 struct specbinding
*p
;
1100 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1101 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1104 return p
>= specpdl
;
1107 /* Store the value NEWVAL into SYMBOL.
1108 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1109 (nil stands for the current buffer/frame).
1111 If BINDFLAG is zero, then if this symbol is supposed to become
1112 local in every buffer where it is set, then we make it local.
1113 If BINDFLAG is nonzero, we don't do that. */
1116 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1118 int voide
= EQ (newval
, Qunbound
);
1119 struct Lisp_Symbol
*sym
;
1122 /* If restoring in a dead buffer, do nothing. */
1123 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1126 CHECK_SYMBOL (symbol
);
1127 if (SYMBOL_CONSTANT_P (symbol
))
1129 if (NILP (Fkeywordp (symbol
))
1130 || !EQ (newval
, Fsymbol_value (symbol
)))
1131 xsignal1 (Qsetting_constant
, symbol
);
1133 /* Allow setting keywords to their own value. */
1137 sym
= XSYMBOL (symbol
);
1140 switch (sym
->redirect
)
1142 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1143 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1144 case SYMBOL_LOCALIZED
:
1146 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1149 if (blv
->frame_local
)
1150 where
= selected_frame
;
1152 XSETBUFFER (where
, current_buffer
);
1154 /* If the current buffer is not the buffer whose binding is
1155 loaded, or if there may be frame-local bindings and the frame
1156 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1157 the default binding is loaded, the loaded binding may be the
1159 if (!EQ (blv
->where
, where
)
1160 /* Also unload a global binding (if the var is local_if_set). */
1161 || (EQ (blv
->valcell
, blv
->defcell
)))
1163 /* The currently loaded binding is not necessarily valid.
1164 We need to unload it, and choose a new binding. */
1166 /* Write out `realvalue' to the old loaded binding. */
1168 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1170 /* Find the new binding. */
1171 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1172 tem1
= Fassq (symbol
,
1174 ? XFRAME (where
)->param_alist
1175 : BVAR (XBUFFER (where
), local_var_alist
)));
1181 /* This buffer still sees the default value. */
1183 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1184 or if this is `let' rather than `set',
1185 make CURRENT-ALIST-ELEMENT point to itself,
1186 indicating that we're seeing the default value.
1187 Likewise if the variable has been let-bound
1188 in the current buffer. */
1189 if (bindflag
|| !blv
->local_if_set
1190 || let_shadows_buffer_binding_p (sym
))
1193 tem1
= blv
->defcell
;
1195 /* If it's a local_if_set, being set not bound,
1196 and we're not within a let that was made for this buffer,
1197 create a new buffer-local binding for the variable.
1198 That means, give this buffer a new assoc for a local value
1199 and load that binding. */
1202 /* local_if_set is only supported for buffer-local
1203 bindings, not for frame-local bindings. */
1204 eassert (!blv
->frame_local
);
1205 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1206 BVAR (XBUFFER (where
), local_var_alist
)
1207 = Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
));
1211 /* Record which binding is now loaded. */
1212 blv
->valcell
= tem1
;
1215 /* Store the new value in the cons cell. */
1216 SET_BLV_VALUE (blv
, newval
);
1221 /* If storing void (making the symbol void), forward only through
1222 buffer-local indicator, not through Lisp_Objfwd, etc. */
1225 store_symval_forwarding (blv
->fwd
, newval
,
1227 ? XBUFFER (where
) : current_buffer
);
1231 case SYMBOL_FORWARDED
:
1234 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1235 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1236 if (BUFFER_OBJFWDP (innercontents
))
1238 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1239 int idx
= PER_BUFFER_IDX (offset
);
1242 && !let_shadows_buffer_binding_p (sym
))
1243 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1247 { /* If storing void (making the symbol void), forward only through
1248 buffer-local indicator, not through Lisp_Objfwd, etc. */
1249 sym
->redirect
= SYMBOL_PLAINVAL
;
1250 SET_SYMBOL_VAL (sym
, newval
);
1253 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1261 /* Access or set a buffer-local symbol's default value. */
1263 /* Return the default value of SYMBOL, but don't check for voidness.
1264 Return Qunbound if it is void. */
1267 default_value (Lisp_Object symbol
)
1269 struct Lisp_Symbol
*sym
;
1271 CHECK_SYMBOL (symbol
);
1272 sym
= XSYMBOL (symbol
);
1275 switch (sym
->redirect
)
1277 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1278 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1279 case SYMBOL_LOCALIZED
:
1281 /* If var is set up for a buffer that lacks a local value for it,
1282 the current value is nominally the default value.
1283 But the `realvalue' slot may be more up to date, since
1284 ordinary setq stores just that slot. So use that. */
1285 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1286 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1287 return do_symval_forwarding (blv
->fwd
);
1289 return XCDR (blv
->defcell
);
1291 case SYMBOL_FORWARDED
:
1293 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1295 /* For a built-in buffer-local variable, get the default value
1296 rather than letting do_symval_forwarding get the current value. */
1297 if (BUFFER_OBJFWDP (valcontents
))
1299 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1300 if (PER_BUFFER_IDX (offset
) != 0)
1301 return PER_BUFFER_DEFAULT (offset
);
1304 /* For other variables, get the current value. */
1305 return do_symval_forwarding (valcontents
);
1311 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1312 doc
: /* Return t if SYMBOL has a non-void default value.
1313 This is the value that is seen in buffers that do not have their own values
1314 for this variable. */)
1315 (Lisp_Object symbol
)
1317 register Lisp_Object value
;
1319 value
= default_value (symbol
);
1320 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1323 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1324 doc
: /* Return SYMBOL's default value.
1325 This is the value that is seen in buffers that do not have their own values
1326 for this variable. The default value is meaningful for variables with
1327 local bindings in certain buffers. */)
1328 (Lisp_Object symbol
)
1330 register Lisp_Object value
;
1332 value
= default_value (symbol
);
1333 if (!EQ (value
, Qunbound
))
1336 xsignal1 (Qvoid_variable
, symbol
);
1339 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1340 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1341 The default value is seen in buffers that do not have their own values
1342 for this variable. */)
1343 (Lisp_Object symbol
, Lisp_Object value
)
1345 struct Lisp_Symbol
*sym
;
1347 CHECK_SYMBOL (symbol
);
1348 if (SYMBOL_CONSTANT_P (symbol
))
1350 if (NILP (Fkeywordp (symbol
))
1351 || !EQ (value
, Fdefault_value (symbol
)))
1352 xsignal1 (Qsetting_constant
, symbol
);
1354 /* Allow setting keywords to their own value. */
1357 sym
= XSYMBOL (symbol
);
1360 switch (sym
->redirect
)
1362 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1363 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1364 case SYMBOL_LOCALIZED
:
1366 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1368 /* Store new value into the DEFAULT-VALUE slot. */
1369 XSETCDR (blv
->defcell
, value
);
1371 /* If the default binding is now loaded, set the REALVALUE slot too. */
1372 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1373 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1376 case SYMBOL_FORWARDED
:
1378 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1380 /* Handle variables like case-fold-search that have special slots
1382 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1383 if (BUFFER_OBJFWDP (valcontents
))
1385 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1386 int idx
= PER_BUFFER_IDX (offset
);
1388 PER_BUFFER_DEFAULT (offset
) = value
;
1390 /* If this variable is not always local in all buffers,
1391 set it in the buffers that don't nominally have a local value. */
1396 for (b
= all_buffers
; b
; b
= b
->next
)
1397 if (!PER_BUFFER_VALUE_P (b
, idx
))
1398 PER_BUFFER_VALUE (b
, offset
) = value
;
1403 return Fset (symbol
, value
);
1409 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1410 doc
: /* Set the default value of variable VAR to VALUE.
1411 VAR, the variable name, is literal (not evaluated);
1412 VALUE is an expression: it is evaluated and its value returned.
1413 The default value of a variable is seen in buffers
1414 that do not have their own values for the variable.
1416 More generally, you can use multiple variables and values, as in
1417 (setq-default VAR VALUE VAR VALUE...)
1418 This sets each VAR's default value to the corresponding VALUE.
1419 The VALUE for the Nth VAR can refer to the new default values
1421 usage: (setq-default [VAR VALUE]...) */)
1424 register Lisp_Object args_left
;
1425 register Lisp_Object val
, symbol
;
1426 struct gcpro gcpro1
;
1436 val
= eval_sub (Fcar (Fcdr (args_left
)));
1437 symbol
= XCAR (args_left
);
1438 Fset_default (symbol
, val
);
1439 args_left
= Fcdr (XCDR (args_left
));
1441 while (!NILP (args_left
));
1447 /* Lisp functions for creating and removing buffer-local variables. */
1452 union Lisp_Fwd
*fwd
;
1455 static struct Lisp_Buffer_Local_Value
*
1456 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1458 struct Lisp_Buffer_Local_Value
*blv
1459 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1463 XSETSYMBOL (symbol
, sym
);
1464 tem
= Fcons (symbol
, (forwarded
1465 ? do_symval_forwarding (valcontents
.fwd
)
1466 : valcontents
.value
));
1468 /* Buffer_Local_Values cannot have as realval a buffer-local
1469 or keyboard-local forwarding. */
1470 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1471 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1472 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1474 blv
->frame_local
= 0;
1475 blv
->local_if_set
= 0;
1478 SET_BLV_FOUND (blv
, 0);
1482 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
,
1483 Smake_variable_buffer_local
, 1, 1, "vMake Variable Buffer Local: ",
1484 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1485 At any time, the value for the current buffer is in effect,
1486 unless the variable has never been set in this buffer,
1487 in which case the default value is in effect.
1488 Note that binding the variable with `let', or setting it while
1489 a `let'-style binding made in this buffer is in effect,
1490 does not make the variable buffer-local. Return VARIABLE.
1492 In most cases it is better to use `make-local-variable',
1493 which makes a variable local in just one buffer.
1495 The function `default-value' gets the default value and `set-default' sets it. */)
1496 (register Lisp_Object variable
)
1498 struct Lisp_Symbol
*sym
;
1499 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1500 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1501 int forwarded
IF_LINT (= 0);
1503 CHECK_SYMBOL (variable
);
1504 sym
= XSYMBOL (variable
);
1507 switch (sym
->redirect
)
1509 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1510 case SYMBOL_PLAINVAL
:
1511 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1512 if (EQ (valcontents
.value
, Qunbound
))
1513 valcontents
.value
= Qnil
;
1515 case SYMBOL_LOCALIZED
:
1516 blv
= SYMBOL_BLV (sym
);
1517 if (blv
->frame_local
)
1518 error ("Symbol %s may not be buffer-local",
1519 SDATA (SYMBOL_NAME (variable
)));
1521 case SYMBOL_FORWARDED
:
1522 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1523 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1524 error ("Symbol %s may not be buffer-local",
1525 SDATA (SYMBOL_NAME (variable
)));
1526 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1533 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1537 blv
= make_blv (sym
, forwarded
, valcontents
);
1538 sym
->redirect
= SYMBOL_LOCALIZED
;
1539 SET_SYMBOL_BLV (sym
, blv
);
1542 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1543 if (let_shadows_global_binding_p (symbol
))
1544 message ("Making %s buffer-local while let-bound!",
1545 SDATA (SYMBOL_NAME (variable
)));
1549 blv
->local_if_set
= 1;
1553 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1554 1, 1, "vMake Local Variable: ",
1555 doc
: /* Make VARIABLE have a separate value in the current buffer.
1556 Other buffers will continue to share a common default value.
1557 \(The buffer-local value of VARIABLE starts out as the same value
1558 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1561 If the variable is already arranged to become local when set,
1562 this function causes a local value to exist for this buffer,
1563 just as setting the variable would do.
1565 This function returns VARIABLE, and therefore
1566 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1569 See also `make-variable-buffer-local'.
1571 Do not use `make-local-variable' to make a hook variable buffer-local.
1572 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1573 (register Lisp_Object variable
)
1575 register Lisp_Object tem
;
1576 int forwarded
IF_LINT (= 0);
1577 union Lisp_Val_Fwd valcontents
IF_LINT (= {0});
1578 struct Lisp_Symbol
*sym
;
1579 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1581 CHECK_SYMBOL (variable
);
1582 sym
= XSYMBOL (variable
);
1585 switch (sym
->redirect
)
1587 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1588 case SYMBOL_PLAINVAL
:
1589 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1590 case SYMBOL_LOCALIZED
:
1591 blv
= SYMBOL_BLV (sym
);
1592 if (blv
->frame_local
)
1593 error ("Symbol %s may not be buffer-local",
1594 SDATA (SYMBOL_NAME (variable
)));
1596 case SYMBOL_FORWARDED
:
1597 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1598 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1599 error ("Symbol %s may not be buffer-local",
1600 SDATA (SYMBOL_NAME (variable
)));
1606 error ("Symbol %s may not be buffer-local",
1607 SDATA (SYMBOL_NAME (variable
)));
1609 if (blv
? blv
->local_if_set
1610 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1612 tem
= Fboundp (variable
);
1613 /* Make sure the symbol has a local value in this particular buffer,
1614 by setting it to the same value it already has. */
1615 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1620 blv
= make_blv (sym
, forwarded
, valcontents
);
1621 sym
->redirect
= SYMBOL_LOCALIZED
;
1622 SET_SYMBOL_BLV (sym
, blv
);
1625 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1626 if (let_shadows_global_binding_p (symbol
))
1627 message ("Making %s local to %s while let-bound!",
1628 SDATA (SYMBOL_NAME (variable
)),
1629 SDATA (BVAR (current_buffer
, name
)));
1633 /* Make sure this buffer has its own value of symbol. */
1634 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1635 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1638 if (let_shadows_buffer_binding_p (sym
))
1639 message ("Making %s buffer-local while locally let-bound!",
1640 SDATA (SYMBOL_NAME (variable
)));
1642 /* Swap out any local binding for some other buffer, and make
1643 sure the current value is permanently recorded, if it's the
1645 find_symbol_value (variable
);
1647 BVAR (current_buffer
, local_var_alist
)
1648 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1649 BVAR (current_buffer
, local_var_alist
));
1651 /* Make sure symbol does not think it is set up for this buffer;
1652 force it to look once again for this buffer's value. */
1653 if (current_buffer
== XBUFFER (blv
->where
))
1655 /* blv->valcell = blv->defcell;
1656 * SET_BLV_FOUND (blv, 0); */
1660 /* If the symbol forwards into a C variable, then load the binding
1661 for this buffer now. If C code modifies the variable before we
1662 load the binding in, then that new value will clobber the default
1663 binding the next time we unload it. */
1665 swap_in_symval_forwarding (sym
, blv
);
1670 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1671 1, 1, "vKill Local Variable: ",
1672 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1673 From now on the default value will apply in this buffer. Return VARIABLE. */)
1674 (register Lisp_Object variable
)
1676 register Lisp_Object tem
;
1677 struct Lisp_Buffer_Local_Value
*blv
;
1678 struct Lisp_Symbol
*sym
;
1680 CHECK_SYMBOL (variable
);
1681 sym
= XSYMBOL (variable
);
1684 switch (sym
->redirect
)
1686 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1687 case SYMBOL_PLAINVAL
: return variable
;
1688 case SYMBOL_FORWARDED
:
1690 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1691 if (BUFFER_OBJFWDP (valcontents
))
1693 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1694 int idx
= PER_BUFFER_IDX (offset
);
1698 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1699 PER_BUFFER_VALUE (current_buffer
, offset
)
1700 = PER_BUFFER_DEFAULT (offset
);
1705 case SYMBOL_LOCALIZED
:
1706 blv
= SYMBOL_BLV (sym
);
1707 if (blv
->frame_local
)
1713 /* Get rid of this buffer's alist element, if any. */
1714 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1715 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1717 BVAR (current_buffer
, local_var_alist
)
1718 = Fdelq (tem
, BVAR (current_buffer
, local_var_alist
));
1720 /* If the symbol is set up with the current buffer's binding
1721 loaded, recompute its value. We have to do it now, or else
1722 forwarded objects won't work right. */
1724 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1725 if (EQ (buf
, blv
->where
))
1728 /* blv->valcell = blv->defcell;
1729 * SET_BLV_FOUND (blv, 0); */
1731 find_symbol_value (variable
);
1738 /* Lisp functions for creating and removing buffer-local variables. */
1740 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1741 when/if this is removed. */
1743 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1744 1, 1, "vMake Variable Frame Local: ",
1745 doc
: /* Enable VARIABLE to have frame-local bindings.
1746 This does not create any frame-local bindings for VARIABLE,
1747 it just makes them possible.
1749 A frame-local binding is actually a frame parameter value.
1750 If a frame F has a value for the frame parameter named VARIABLE,
1751 that also acts as a frame-local binding for VARIABLE in F--
1752 provided this function has been called to enable VARIABLE
1753 to have frame-local bindings at all.
1755 The only way to create a frame-local binding for VARIABLE in a frame
1756 is to set the VARIABLE frame parameter of that frame. See
1757 `modify-frame-parameters' for how to set frame parameters.
1759 Note that since Emacs 23.1, variables cannot be both buffer-local and
1760 frame-local any more (buffer-local bindings used to take precedence over
1761 frame-local bindings). */)
1762 (register Lisp_Object variable
)
1765 union Lisp_Val_Fwd valcontents
;
1766 struct Lisp_Symbol
*sym
;
1767 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1769 CHECK_SYMBOL (variable
);
1770 sym
= XSYMBOL (variable
);
1773 switch (sym
->redirect
)
1775 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1776 case SYMBOL_PLAINVAL
:
1777 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1778 if (EQ (valcontents
.value
, Qunbound
))
1779 valcontents
.value
= Qnil
;
1781 case SYMBOL_LOCALIZED
:
1782 if (SYMBOL_BLV (sym
)->frame_local
)
1785 error ("Symbol %s may not be frame-local",
1786 SDATA (SYMBOL_NAME (variable
)));
1787 case SYMBOL_FORWARDED
:
1788 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1789 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1790 error ("Symbol %s may not be frame-local",
1791 SDATA (SYMBOL_NAME (variable
)));
1797 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1799 blv
= make_blv (sym
, forwarded
, valcontents
);
1800 blv
->frame_local
= 1;
1801 sym
->redirect
= SYMBOL_LOCALIZED
;
1802 SET_SYMBOL_BLV (sym
, blv
);
1805 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1806 if (let_shadows_global_binding_p (symbol
))
1807 message ("Making %s frame-local while let-bound!",
1808 SDATA (SYMBOL_NAME (variable
)));
1813 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1815 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1816 BUFFER defaults to the current buffer. */)
1817 (register Lisp_Object variable
, Lisp_Object buffer
)
1819 register struct buffer
*buf
;
1820 struct Lisp_Symbol
*sym
;
1823 buf
= current_buffer
;
1826 CHECK_BUFFER (buffer
);
1827 buf
= XBUFFER (buffer
);
1830 CHECK_SYMBOL (variable
);
1831 sym
= XSYMBOL (variable
);
1834 switch (sym
->redirect
)
1836 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1837 case SYMBOL_PLAINVAL
: return Qnil
;
1838 case SYMBOL_LOCALIZED
:
1840 Lisp_Object tail
, elt
, tmp
;
1841 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1842 XSETBUFFER (tmp
, buf
);
1843 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1845 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1848 if (EQ (variable
, XCAR (elt
)))
1850 eassert (!blv
->frame_local
);
1851 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1855 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1858 case SYMBOL_FORWARDED
:
1860 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1861 if (BUFFER_OBJFWDP (valcontents
))
1863 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1864 int idx
= PER_BUFFER_IDX (offset
);
1865 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1874 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1876 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1877 More precisely, this means that setting the variable \(with `set' or`setq'),
1878 while it does not have a `let'-style binding that was made in BUFFER,
1879 will produce a buffer local binding. See Info node
1880 `(elisp)Creating Buffer-Local'.
1881 BUFFER defaults to the current buffer. */)
1882 (register Lisp_Object variable
, Lisp_Object buffer
)
1884 struct Lisp_Symbol
*sym
;
1886 CHECK_SYMBOL (variable
);
1887 sym
= XSYMBOL (variable
);
1890 switch (sym
->redirect
)
1892 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1893 case SYMBOL_PLAINVAL
: return Qnil
;
1894 case SYMBOL_LOCALIZED
:
1896 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1897 if (blv
->local_if_set
)
1899 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1900 return Flocal_variable_p (variable
, buffer
);
1902 case SYMBOL_FORWARDED
:
1903 /* All BUFFER_OBJFWD slots become local if they are set. */
1904 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1909 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1911 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1912 If the current binding is buffer-local, the value is the current buffer.
1913 If the current binding is frame-local, the value is the selected frame.
1914 If the current binding is global (the default), the value is nil. */)
1915 (register Lisp_Object variable
)
1917 struct Lisp_Symbol
*sym
;
1919 CHECK_SYMBOL (variable
);
1920 sym
= XSYMBOL (variable
);
1922 /* Make sure the current binding is actually swapped in. */
1923 find_symbol_value (variable
);
1926 switch (sym
->redirect
)
1928 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1929 case SYMBOL_PLAINVAL
: return Qnil
;
1930 case SYMBOL_FORWARDED
:
1932 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1933 if (KBOARD_OBJFWDP (valcontents
))
1934 return Fframe_terminal (Fselected_frame ());
1935 else if (!BUFFER_OBJFWDP (valcontents
))
1939 case SYMBOL_LOCALIZED
:
1940 /* For a local variable, record both the symbol and which
1941 buffer's or frame's value we are saving. */
1942 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1943 return Fcurrent_buffer ();
1944 else if (sym
->redirect
== SYMBOL_LOCALIZED
1945 && BLV_FOUND (SYMBOL_BLV (sym
)))
1946 return SYMBOL_BLV (sym
)->where
;
1953 /* This code is disabled now that we use the selected frame to return
1954 keyboard-local-values. */
1956 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1958 DEFUN ("terminal-local-value", Fterminal_local_value
,
1959 Sterminal_local_value
, 2, 2, 0,
1960 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1961 If SYMBOL is not a terminal-local variable, then return its normal
1962 value, like `symbol-value'.
1964 TERMINAL may be a terminal object, a frame, or nil (meaning the
1965 selected frame's terminal device). */)
1966 (Lisp_Object symbol
, Lisp_Object terminal
)
1969 struct terminal
*t
= get_terminal (terminal
, 1);
1970 push_kboard (t
->kboard
);
1971 result
= Fsymbol_value (symbol
);
1976 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
,
1977 Sset_terminal_local_value
, 3, 3, 0,
1978 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1979 If VARIABLE is not a terminal-local variable, then set its normal
1980 binding, like `set'.
1982 TERMINAL may be a terminal object, a frame, or nil (meaning the
1983 selected frame's terminal device). */)
1984 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1987 struct terminal
*t
= get_terminal (terminal
, 1);
1988 push_kboard (d
->kboard
);
1989 result
= Fset (symbol
, value
);
1995 /* Find the function at the end of a chain of symbol function indirections. */
1997 /* If OBJECT is a symbol, find the end of its function chain and
1998 return the value found there. If OBJECT is not a symbol, just
1999 return it. If there is a cycle in the function chain, signal a
2000 cyclic-function-indirection error.
2002 This is like Findirect_function, except that it doesn't signal an
2003 error if the chain ends up unbound. */
2005 indirect_function (register Lisp_Object object
)
2007 Lisp_Object tortoise
, hare
;
2009 hare
= tortoise
= object
;
2013 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2015 hare
= XSYMBOL (hare
)->function
;
2016 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2018 hare
= XSYMBOL (hare
)->function
;
2020 tortoise
= XSYMBOL (tortoise
)->function
;
2022 if (EQ (hare
, tortoise
))
2023 xsignal1 (Qcyclic_function_indirection
, object
);
2029 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2030 doc
: /* Return the function at the end of OBJECT's function chain.
2031 If OBJECT is not a symbol, just return it. Otherwise, follow all
2032 function indirections to find the final function binding and return it.
2033 If the final symbol in the chain is unbound, signal a void-function error.
2034 Optional arg NOERROR non-nil means to return nil instead of signalling.
2035 Signal a cyclic-function-indirection error if there is a loop in the
2036 function chain of symbols. */)
2037 (register Lisp_Object object
, Lisp_Object noerror
)
2041 /* Optimize for no indirection. */
2043 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2044 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2045 result
= indirect_function (result
);
2046 if (!EQ (result
, Qunbound
))
2050 xsignal1 (Qvoid_function
, object
);
2055 /* Extract and set vector and string elements */
2057 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2058 doc
: /* Return the element of ARRAY at index IDX.
2059 ARRAY may be a vector, a string, a char-table, a bool-vector,
2060 or a byte-code object. IDX starts at 0. */)
2061 (register Lisp_Object array
, Lisp_Object idx
)
2063 register EMACS_INT idxval
;
2066 idxval
= XINT (idx
);
2067 if (STRINGP (array
))
2070 EMACS_INT idxval_byte
;
2072 if (idxval
< 0 || idxval
>= SCHARS (array
))
2073 args_out_of_range (array
, idx
);
2074 if (! STRING_MULTIBYTE (array
))
2075 return make_number ((unsigned char) SREF (array
, idxval
));
2076 idxval_byte
= string_char_to_byte (array
, idxval
);
2078 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2079 return make_number (c
);
2081 else if (BOOL_VECTOR_P (array
))
2085 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2086 args_out_of_range (array
, idx
);
2088 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2089 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2091 else if (CHAR_TABLE_P (array
))
2093 CHECK_CHARACTER (idx
);
2094 return CHAR_TABLE_REF (array
, idxval
);
2099 if (VECTORP (array
))
2100 size
= XVECTOR (array
)->size
;
2101 else if (COMPILEDP (array
))
2102 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2104 wrong_type_argument (Qarrayp
, array
);
2106 if (idxval
< 0 || idxval
>= size
)
2107 args_out_of_range (array
, idx
);
2108 return AREF (array
, idxval
);
2112 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2113 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2114 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2115 bool-vector. IDX starts at 0. */)
2116 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2118 register EMACS_INT idxval
;
2121 idxval
= XINT (idx
);
2122 CHECK_ARRAY (array
, Qarrayp
);
2123 CHECK_IMPURE (array
);
2125 if (VECTORP (array
))
2127 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2128 args_out_of_range (array
, idx
);
2129 XVECTOR (array
)->contents
[idxval
] = newelt
;
2131 else if (BOOL_VECTOR_P (array
))
2135 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2136 args_out_of_range (array
, idx
);
2138 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2140 if (! NILP (newelt
))
2141 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2143 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2144 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2146 else if (CHAR_TABLE_P (array
))
2148 CHECK_CHARACTER (idx
);
2149 CHAR_TABLE_SET (array
, idxval
, newelt
);
2151 else if (STRING_MULTIBYTE (array
))
2153 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2154 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2156 if (idxval
< 0 || idxval
>= SCHARS (array
))
2157 args_out_of_range (array
, idx
);
2158 CHECK_CHARACTER (newelt
);
2160 nbytes
= SBYTES (array
);
2162 idxval_byte
= string_char_to_byte (array
, idxval
);
2163 p1
= SDATA (array
) + idxval_byte
;
2164 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2165 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2166 if (prev_bytes
!= new_bytes
)
2168 /* We must relocate the string data. */
2169 EMACS_INT nchars
= SCHARS (array
);
2173 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2174 memcpy (str
, SDATA (array
), nbytes
);
2175 allocate_string_data (XSTRING (array
), nchars
,
2176 nbytes
+ new_bytes
- prev_bytes
);
2177 memcpy (SDATA (array
), str
, idxval_byte
);
2178 p1
= SDATA (array
) + idxval_byte
;
2179 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2180 nbytes
- (idxval_byte
+ prev_bytes
));
2182 clear_string_char_byte_cache ();
2189 if (idxval
< 0 || idxval
>= SCHARS (array
))
2190 args_out_of_range (array
, idx
);
2191 CHECK_NUMBER (newelt
);
2193 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2197 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2198 if (SREF (array
, i
) >= 0x80)
2199 args_out_of_range (array
, newelt
);
2200 /* ARRAY is an ASCII string. Convert it to a multibyte
2201 string, and try `aset' again. */
2202 STRING_SET_MULTIBYTE (array
);
2203 return Faset (array
, idx
, newelt
);
2205 SSET (array
, idxval
, XINT (newelt
));
2211 /* Arithmetic functions */
2213 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2216 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2218 double f1
= 0, f2
= 0;
2221 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2222 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2224 if (FLOATP (num1
) || FLOATP (num2
))
2227 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2228 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2234 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2239 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2244 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2249 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2254 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2259 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2268 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2269 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2270 (register Lisp_Object num1
, Lisp_Object num2
)
2272 return arithcompare (num1
, num2
, equal
);
2275 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2276 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2277 (register Lisp_Object num1
, Lisp_Object num2
)
2279 return arithcompare (num1
, num2
, less
);
2282 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2283 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2284 (register Lisp_Object num1
, Lisp_Object num2
)
2286 return arithcompare (num1
, num2
, grtr
);
2289 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2290 doc
: /* Return t if first arg is less than or equal to second arg.
2291 Both must be numbers or markers. */)
2292 (register Lisp_Object num1
, Lisp_Object num2
)
2294 return arithcompare (num1
, num2
, less_or_equal
);
2297 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2298 doc
: /* Return t if first arg is greater than or equal to second arg.
2299 Both must be numbers or markers. */)
2300 (register Lisp_Object num1
, Lisp_Object num2
)
2302 return arithcompare (num1
, num2
, grtr_or_equal
);
2305 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2306 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2307 (register Lisp_Object num1
, Lisp_Object num2
)
2309 return arithcompare (num1
, num2
, notequal
);
2312 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2313 doc
: /* Return t if NUMBER is zero. */)
2314 (register Lisp_Object number
)
2316 CHECK_NUMBER_OR_FLOAT (number
);
2318 if (FLOATP (number
))
2320 if (XFLOAT_DATA (number
) == 0.0)
2330 /* Convert between long values and pairs of Lisp integers.
2331 Note that long_to_cons returns a single Lisp integer
2332 when the value fits in one. */
2335 long_to_cons (long unsigned int i
)
2337 unsigned long top
= i
>> 16;
2338 unsigned int bot
= i
& 0xFFFF;
2340 return make_number (bot
);
2341 if (top
== (unsigned long)-1 >> 16)
2342 return Fcons (make_number (-1), make_number (bot
));
2343 return Fcons (make_number (top
), make_number (bot
));
2347 cons_to_long (Lisp_Object c
)
2349 Lisp_Object top
, bot
;
2356 return ((XINT (top
) << 16) | XINT (bot
));
2359 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2360 doc
: /* Return the decimal representation of NUMBER as a string.
2361 Uses a minus sign if negative.
2362 NUMBER may be an integer or a floating point number. */)
2363 (Lisp_Object number
)
2365 char buffer
[VALBITS
];
2367 CHECK_NUMBER_OR_FLOAT (number
);
2369 if (FLOATP (number
))
2371 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2373 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2374 return build_string (pigbuf
);
2377 if (sizeof (int) == sizeof (EMACS_INT
))
2378 sprintf (buffer
, "%d", (int) XINT (number
));
2379 else if (sizeof (long) == sizeof (EMACS_INT
))
2380 sprintf (buffer
, "%ld", (long) XINT (number
));
2383 return build_string (buffer
);
2387 digit_to_number (int character
, int base
)
2391 if (character
>= '0' && character
<= '9')
2392 digit
= character
- '0';
2393 else if (character
>= 'a' && character
<= 'z')
2394 digit
= character
- 'a' + 10;
2395 else if (character
>= 'A' && character
<= 'Z')
2396 digit
= character
- 'A' + 10;
2406 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2407 doc
: /* Parse STRING as a decimal number and return the number.
2408 This parses both integers and floating point numbers.
2409 It ignores leading spaces and tabs, and all trailing chars.
2411 If BASE, interpret STRING as a number in that base. If BASE isn't
2412 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2413 If the base used is not 10, STRING is always parsed as integer. */)
2414 (register Lisp_Object string
, Lisp_Object base
)
2421 CHECK_STRING (string
);
2427 CHECK_NUMBER (base
);
2429 if (b
< 2 || b
> 16)
2430 xsignal1 (Qargs_out_of_range
, base
);
2433 /* Skip any whitespace at the front of the number. Some versions of
2434 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2435 p
= SSDATA (string
);
2436 while (*p
== ' ' || *p
== '\t')
2447 if (isfloat_string (p
, 1) && b
== 10)
2448 val
= make_float (sign
* atof (p
));
2455 int digit
= digit_to_number (*p
++, b
);
2461 val
= make_fixnum_or_float (sign
* v
);
2481 static Lisp_Object
float_arith_driver (double, size_t, enum arithop
,
2482 size_t, Lisp_Object
*);
2484 arith_driver (enum arithop code
, size_t nargs
, register Lisp_Object
*args
)
2486 register Lisp_Object val
;
2487 register size_t argnum
;
2488 register EMACS_INT accum
= 0;
2489 register EMACS_INT next
;
2491 switch (SWITCH_ENUM_CAST (code
))
2509 for (argnum
= 0; argnum
< nargs
; argnum
++)
2511 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2513 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2516 return float_arith_driver ((double) accum
, argnum
, code
,
2519 next
= XINT (args
[argnum
]);
2520 switch (SWITCH_ENUM_CAST (code
))
2526 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2537 xsignal0 (Qarith_error
);
2551 if (!argnum
|| next
> accum
)
2555 if (!argnum
|| next
< accum
)
2561 XSETINT (val
, accum
);
2566 #define isnan(x) ((x) != (x))
2569 float_arith_driver (double accum
, register size_t argnum
, enum arithop code
,
2570 size_t nargs
, register Lisp_Object
*args
)
2572 register Lisp_Object val
;
2575 for (; argnum
< nargs
; argnum
++)
2577 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2578 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2582 next
= XFLOAT_DATA (val
);
2586 args
[argnum
] = val
; /* runs into a compiler bug. */
2587 next
= XINT (args
[argnum
]);
2589 switch (SWITCH_ENUM_CAST (code
))
2595 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2605 if (! IEEE_FLOATING_POINT
&& next
== 0)
2606 xsignal0 (Qarith_error
);
2613 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2615 if (!argnum
|| isnan (next
) || next
> accum
)
2619 if (!argnum
|| isnan (next
) || next
< accum
)
2625 return make_float (accum
);
2629 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2630 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2631 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2632 (size_t nargs
, Lisp_Object
*args
)
2634 return arith_driver (Aadd
, nargs
, args
);
2637 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2638 doc
: /* Negate number or subtract numbers or markers and return the result.
2639 With one arg, negates it. With more than one arg,
2640 subtracts all but the first from the first.
2641 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2642 (size_t nargs
, Lisp_Object
*args
)
2644 return arith_driver (Asub
, nargs
, args
);
2647 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2648 doc
: /* Return product of any number of arguments, which are numbers or markers.
2649 usage: (* &rest NUMBERS-OR-MARKERS) */)
2650 (size_t nargs
, Lisp_Object
*args
)
2652 return arith_driver (Amult
, nargs
, args
);
2655 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2656 doc
: /* Return first argument divided by all the remaining arguments.
2657 The arguments must be numbers or markers.
2658 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2659 (size_t nargs
, Lisp_Object
*args
)
2662 for (argnum
= 2; argnum
< nargs
; argnum
++)
2663 if (FLOATP (args
[argnum
]))
2664 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2665 return arith_driver (Adiv
, nargs
, args
);
2668 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2669 doc
: /* Return remainder of X divided by Y.
2670 Both must be integers or markers. */)
2671 (register Lisp_Object x
, Lisp_Object y
)
2675 CHECK_NUMBER_COERCE_MARKER (x
);
2676 CHECK_NUMBER_COERCE_MARKER (y
);
2678 if (XFASTINT (y
) == 0)
2679 xsignal0 (Qarith_error
);
2681 XSETINT (val
, XINT (x
) % XINT (y
));
2695 /* If the magnitude of the result exceeds that of the divisor, or
2696 the sign of the result does not agree with that of the dividend,
2697 iterate with the reduced value. This does not yield a
2698 particularly accurate result, but at least it will be in the
2699 range promised by fmod. */
2701 r
-= f2
* floor (r
/ f2
);
2702 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2706 #endif /* ! HAVE_FMOD */
2708 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2709 doc
: /* Return X modulo Y.
2710 The result falls between zero (inclusive) and Y (exclusive).
2711 Both X and Y must be numbers or markers. */)
2712 (register Lisp_Object x
, Lisp_Object y
)
2717 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2718 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2720 if (FLOATP (x
) || FLOATP (y
))
2721 return fmod_float (x
, y
);
2727 xsignal0 (Qarith_error
);
2731 /* If the "remainder" comes out with the wrong sign, fix it. */
2732 if (i2
< 0 ? i1
> 0 : i1
< 0)
2739 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2740 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2741 The value is always a number; markers are converted to numbers.
2742 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2743 (size_t nargs
, Lisp_Object
*args
)
2745 return arith_driver (Amax
, nargs
, args
);
2748 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2749 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2750 The value is always a number; markers are converted to numbers.
2751 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2752 (size_t nargs
, Lisp_Object
*args
)
2754 return arith_driver (Amin
, nargs
, args
);
2757 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2758 doc
: /* Return bitwise-and of all the arguments.
2759 Arguments may be integers, or markers converted to integers.
2760 usage: (logand &rest INTS-OR-MARKERS) */)
2761 (size_t nargs
, Lisp_Object
*args
)
2763 return arith_driver (Alogand
, nargs
, args
);
2766 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2767 doc
: /* Return bitwise-or of all the arguments.
2768 Arguments may be integers, or markers converted to integers.
2769 usage: (logior &rest INTS-OR-MARKERS) */)
2770 (size_t nargs
, Lisp_Object
*args
)
2772 return arith_driver (Alogior
, nargs
, args
);
2775 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2776 doc
: /* Return bitwise-exclusive-or of all the arguments.
2777 Arguments may be integers, or markers converted to integers.
2778 usage: (logxor &rest INTS-OR-MARKERS) */)
2779 (size_t nargs
, Lisp_Object
*args
)
2781 return arith_driver (Alogxor
, nargs
, args
);
2784 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2785 doc
: /* Return VALUE with its bits shifted left by COUNT.
2786 If COUNT is negative, shifting is actually to the right.
2787 In this case, the sign bit is duplicated. */)
2788 (register Lisp_Object value
, Lisp_Object count
)
2790 register Lisp_Object val
;
2792 CHECK_NUMBER (value
);
2793 CHECK_NUMBER (count
);
2795 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2797 else if (XINT (count
) > 0)
2798 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2799 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2800 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2802 XSETINT (val
, XINT (value
) >> -XINT (count
));
2806 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2807 doc
: /* Return VALUE with its bits shifted left by COUNT.
2808 If COUNT is negative, shifting is actually to the right.
2809 In this case, zeros are shifted in on the left. */)
2810 (register Lisp_Object value
, Lisp_Object count
)
2812 register Lisp_Object val
;
2814 CHECK_NUMBER (value
);
2815 CHECK_NUMBER (count
);
2817 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2819 else if (XINT (count
) > 0)
2820 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2821 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2824 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2828 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2829 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2830 Markers are converted to integers. */)
2831 (register Lisp_Object number
)
2833 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2835 if (FLOATP (number
))
2836 return (make_float (1.0 + XFLOAT_DATA (number
)));
2838 XSETINT (number
, XINT (number
) + 1);
2842 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2843 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2844 Markers are converted to integers. */)
2845 (register Lisp_Object number
)
2847 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2849 if (FLOATP (number
))
2850 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2852 XSETINT (number
, XINT (number
) - 1);
2856 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2857 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2858 (register Lisp_Object number
)
2860 CHECK_NUMBER (number
);
2861 XSETINT (number
, ~XINT (number
));
2865 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2866 doc
: /* Return the byteorder for the machine.
2867 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2868 lowercase l) for small endian machines. */)
2871 unsigned i
= 0x04030201;
2872 int order
= *(char *)&i
== 1 ? 108 : 66;
2874 return make_number (order
);
2882 Lisp_Object error_tail
, arith_tail
;
2884 Qquote
= intern_c_string ("quote");
2885 Qlambda
= intern_c_string ("lambda");
2886 Qsubr
= intern_c_string ("subr");
2887 Qerror_conditions
= intern_c_string ("error-conditions");
2888 Qerror_message
= intern_c_string ("error-message");
2889 Qtop_level
= intern_c_string ("top-level");
2891 Qerror
= intern_c_string ("error");
2892 Qquit
= intern_c_string ("quit");
2893 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2894 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2895 Qvoid_function
= intern_c_string ("void-function");
2896 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2897 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2898 Qvoid_variable
= intern_c_string ("void-variable");
2899 Qsetting_constant
= intern_c_string ("setting-constant");
2900 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2902 Qinvalid_function
= intern_c_string ("invalid-function");
2903 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2904 Qno_catch
= intern_c_string ("no-catch");
2905 Qend_of_file
= intern_c_string ("end-of-file");
2906 Qarith_error
= intern_c_string ("arith-error");
2907 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2908 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2909 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2910 Qtext_read_only
= intern_c_string ("text-read-only");
2911 Qmark_inactive
= intern_c_string ("mark-inactive");
2913 Qlistp
= intern_c_string ("listp");
2914 Qconsp
= intern_c_string ("consp");
2915 Qsymbolp
= intern_c_string ("symbolp");
2916 Qkeywordp
= intern_c_string ("keywordp");
2917 Qintegerp
= intern_c_string ("integerp");
2918 Qnatnump
= intern_c_string ("natnump");
2919 Qwholenump
= intern_c_string ("wholenump");
2920 Qstringp
= intern_c_string ("stringp");
2921 Qarrayp
= intern_c_string ("arrayp");
2922 Qsequencep
= intern_c_string ("sequencep");
2923 Qbufferp
= intern_c_string ("bufferp");
2924 Qvectorp
= intern_c_string ("vectorp");
2925 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2926 Qmarkerp
= intern_c_string ("markerp");
2927 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2928 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2929 Qboundp
= intern_c_string ("boundp");
2930 Qfboundp
= intern_c_string ("fboundp");
2932 Qfloatp
= intern_c_string ("floatp");
2933 Qnumberp
= intern_c_string ("numberp");
2934 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2936 Qchar_table_p
= intern_c_string ("char-table-p");
2937 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2939 Qsubrp
= intern_c_string ("subrp");
2940 Qunevalled
= intern_c_string ("unevalled");
2941 Qmany
= intern_c_string ("many");
2943 Qcdr
= intern_c_string ("cdr");
2945 /* Handle automatic advice activation */
2946 Qad_advice_info
= intern_c_string ("ad-advice-info");
2947 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2949 error_tail
= pure_cons (Qerror
, Qnil
);
2951 /* ERROR is used as a signaler for random errors for which nothing else is right */
2953 Fput (Qerror
, Qerror_conditions
,
2955 Fput (Qerror
, Qerror_message
,
2956 make_pure_c_string ("error"));
2958 Fput (Qquit
, Qerror_conditions
,
2959 pure_cons (Qquit
, Qnil
));
2960 Fput (Qquit
, Qerror_message
,
2961 make_pure_c_string ("Quit"));
2963 Fput (Qwrong_type_argument
, Qerror_conditions
,
2964 pure_cons (Qwrong_type_argument
, error_tail
));
2965 Fput (Qwrong_type_argument
, Qerror_message
,
2966 make_pure_c_string ("Wrong type argument"));
2968 Fput (Qargs_out_of_range
, Qerror_conditions
,
2969 pure_cons (Qargs_out_of_range
, error_tail
));
2970 Fput (Qargs_out_of_range
, Qerror_message
,
2971 make_pure_c_string ("Args out of range"));
2973 Fput (Qvoid_function
, Qerror_conditions
,
2974 pure_cons (Qvoid_function
, error_tail
));
2975 Fput (Qvoid_function
, Qerror_message
,
2976 make_pure_c_string ("Symbol's function definition is void"));
2978 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2979 pure_cons (Qcyclic_function_indirection
, error_tail
));
2980 Fput (Qcyclic_function_indirection
, Qerror_message
,
2981 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2983 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2984 pure_cons (Qcyclic_variable_indirection
, error_tail
));
2985 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2986 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
2988 Qcircular_list
= intern_c_string ("circular-list");
2989 staticpro (&Qcircular_list
);
2990 Fput (Qcircular_list
, Qerror_conditions
,
2991 pure_cons (Qcircular_list
, error_tail
));
2992 Fput (Qcircular_list
, Qerror_message
,
2993 make_pure_c_string ("List contains a loop"));
2995 Fput (Qvoid_variable
, Qerror_conditions
,
2996 pure_cons (Qvoid_variable
, error_tail
));
2997 Fput (Qvoid_variable
, Qerror_message
,
2998 make_pure_c_string ("Symbol's value as variable is void"));
3000 Fput (Qsetting_constant
, Qerror_conditions
,
3001 pure_cons (Qsetting_constant
, error_tail
));
3002 Fput (Qsetting_constant
, Qerror_message
,
3003 make_pure_c_string ("Attempt to set a constant symbol"));
3005 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3006 pure_cons (Qinvalid_read_syntax
, error_tail
));
3007 Fput (Qinvalid_read_syntax
, Qerror_message
,
3008 make_pure_c_string ("Invalid read syntax"));
3010 Fput (Qinvalid_function
, Qerror_conditions
,
3011 pure_cons (Qinvalid_function
, error_tail
));
3012 Fput (Qinvalid_function
, Qerror_message
,
3013 make_pure_c_string ("Invalid function"));
3015 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3016 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3017 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3018 make_pure_c_string ("Wrong number of arguments"));
3020 Fput (Qno_catch
, Qerror_conditions
,
3021 pure_cons (Qno_catch
, error_tail
));
3022 Fput (Qno_catch
, Qerror_message
,
3023 make_pure_c_string ("No catch for tag"));
3025 Fput (Qend_of_file
, Qerror_conditions
,
3026 pure_cons (Qend_of_file
, error_tail
));
3027 Fput (Qend_of_file
, Qerror_message
,
3028 make_pure_c_string ("End of file during parsing"));
3030 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3031 Fput (Qarith_error
, Qerror_conditions
,
3033 Fput (Qarith_error
, Qerror_message
,
3034 make_pure_c_string ("Arithmetic error"));
3036 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3037 pure_cons (Qbeginning_of_buffer
, error_tail
));
3038 Fput (Qbeginning_of_buffer
, Qerror_message
,
3039 make_pure_c_string ("Beginning of buffer"));
3041 Fput (Qend_of_buffer
, Qerror_conditions
,
3042 pure_cons (Qend_of_buffer
, error_tail
));
3043 Fput (Qend_of_buffer
, Qerror_message
,
3044 make_pure_c_string ("End of buffer"));
3046 Fput (Qbuffer_read_only
, Qerror_conditions
,
3047 pure_cons (Qbuffer_read_only
, error_tail
));
3048 Fput (Qbuffer_read_only
, Qerror_message
,
3049 make_pure_c_string ("Buffer is read-only"));
3051 Fput (Qtext_read_only
, Qerror_conditions
,
3052 pure_cons (Qtext_read_only
, error_tail
));
3053 Fput (Qtext_read_only
, Qerror_message
,
3054 make_pure_c_string ("Text is read-only"));
3056 Qrange_error
= intern_c_string ("range-error");
3057 Qdomain_error
= intern_c_string ("domain-error");
3058 Qsingularity_error
= intern_c_string ("singularity-error");
3059 Qoverflow_error
= intern_c_string ("overflow-error");
3060 Qunderflow_error
= intern_c_string ("underflow-error");
3062 Fput (Qdomain_error
, Qerror_conditions
,
3063 pure_cons (Qdomain_error
, arith_tail
));
3064 Fput (Qdomain_error
, Qerror_message
,
3065 make_pure_c_string ("Arithmetic domain error"));
3067 Fput (Qrange_error
, Qerror_conditions
,
3068 pure_cons (Qrange_error
, arith_tail
));
3069 Fput (Qrange_error
, Qerror_message
,
3070 make_pure_c_string ("Arithmetic range error"));
3072 Fput (Qsingularity_error
, Qerror_conditions
,
3073 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3074 Fput (Qsingularity_error
, Qerror_message
,
3075 make_pure_c_string ("Arithmetic singularity error"));
3077 Fput (Qoverflow_error
, Qerror_conditions
,
3078 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3079 Fput (Qoverflow_error
, Qerror_message
,
3080 make_pure_c_string ("Arithmetic overflow error"));
3082 Fput (Qunderflow_error
, Qerror_conditions
,
3083 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3084 Fput (Qunderflow_error
, Qerror_message
,
3085 make_pure_c_string ("Arithmetic underflow error"));
3087 staticpro (&Qrange_error
);
3088 staticpro (&Qdomain_error
);
3089 staticpro (&Qsingularity_error
);
3090 staticpro (&Qoverflow_error
);
3091 staticpro (&Qunderflow_error
);
3095 staticpro (&Qquote
);
3096 staticpro (&Qlambda
);
3098 staticpro (&Qunbound
);
3099 staticpro (&Qerror_conditions
);
3100 staticpro (&Qerror_message
);
3101 staticpro (&Qtop_level
);
3103 staticpro (&Qerror
);
3105 staticpro (&Qwrong_type_argument
);
3106 staticpro (&Qargs_out_of_range
);
3107 staticpro (&Qvoid_function
);
3108 staticpro (&Qcyclic_function_indirection
);
3109 staticpro (&Qcyclic_variable_indirection
);
3110 staticpro (&Qvoid_variable
);
3111 staticpro (&Qsetting_constant
);
3112 staticpro (&Qinvalid_read_syntax
);
3113 staticpro (&Qwrong_number_of_arguments
);
3114 staticpro (&Qinvalid_function
);
3115 staticpro (&Qno_catch
);
3116 staticpro (&Qend_of_file
);
3117 staticpro (&Qarith_error
);
3118 staticpro (&Qbeginning_of_buffer
);
3119 staticpro (&Qend_of_buffer
);
3120 staticpro (&Qbuffer_read_only
);
3121 staticpro (&Qtext_read_only
);
3122 staticpro (&Qmark_inactive
);
3124 staticpro (&Qlistp
);
3125 staticpro (&Qconsp
);
3126 staticpro (&Qsymbolp
);
3127 staticpro (&Qkeywordp
);
3128 staticpro (&Qintegerp
);
3129 staticpro (&Qnatnump
);
3130 staticpro (&Qwholenump
);
3131 staticpro (&Qstringp
);
3132 staticpro (&Qarrayp
);
3133 staticpro (&Qsequencep
);
3134 staticpro (&Qbufferp
);
3135 staticpro (&Qvectorp
);
3136 staticpro (&Qchar_or_string_p
);
3137 staticpro (&Qmarkerp
);
3138 staticpro (&Qbuffer_or_string_p
);
3139 staticpro (&Qinteger_or_marker_p
);
3140 staticpro (&Qfloatp
);
3141 staticpro (&Qnumberp
);
3142 staticpro (&Qnumber_or_marker_p
);
3143 staticpro (&Qchar_table_p
);
3144 staticpro (&Qvector_or_char_table_p
);
3145 staticpro (&Qsubrp
);
3147 staticpro (&Qunevalled
);
3149 staticpro (&Qboundp
);
3150 staticpro (&Qfboundp
);
3152 staticpro (&Qad_advice_info
);
3153 staticpro (&Qad_activate_internal
);
3155 /* Types that type-of returns. */
3156 Qinteger
= intern_c_string ("integer");
3157 Qsymbol
= intern_c_string ("symbol");
3158 Qstring
= intern_c_string ("string");
3159 Qcons
= intern_c_string ("cons");
3160 Qmarker
= intern_c_string ("marker");
3161 Qoverlay
= intern_c_string ("overlay");
3162 Qfloat
= intern_c_string ("float");
3163 Qwindow_configuration
= intern_c_string ("window-configuration");
3164 Qprocess
= intern_c_string ("process");
3165 Qwindow
= intern_c_string ("window");
3166 /* Qsubr = intern_c_string ("subr"); */
3167 Qcompiled_function
= intern_c_string ("compiled-function");
3168 Qbuffer
= intern_c_string ("buffer");
3169 Qframe
= intern_c_string ("frame");
3170 Qvector
= intern_c_string ("vector");
3171 Qchar_table
= intern_c_string ("char-table");
3172 Qbool_vector
= intern_c_string ("bool-vector");
3173 Qhash_table
= intern_c_string ("hash-table");
3175 DEFSYM (Qfont_spec
, "font-spec");
3176 DEFSYM (Qfont_entity
, "font-entity");
3177 DEFSYM (Qfont_object
, "font-object");
3179 DEFSYM (Qinteractive_form
, "interactive-form");
3181 staticpro (&Qinteger
);
3182 staticpro (&Qsymbol
);
3183 staticpro (&Qstring
);
3185 staticpro (&Qmarker
);
3186 staticpro (&Qoverlay
);
3187 staticpro (&Qfloat
);
3188 staticpro (&Qwindow_configuration
);
3189 staticpro (&Qprocess
);
3190 staticpro (&Qwindow
);
3191 /* staticpro (&Qsubr); */
3192 staticpro (&Qcompiled_function
);
3193 staticpro (&Qbuffer
);
3194 staticpro (&Qframe
);
3195 staticpro (&Qvector
);
3196 staticpro (&Qchar_table
);
3197 staticpro (&Qbool_vector
);
3198 staticpro (&Qhash_table
);
3200 defsubr (&Sindirect_variable
);
3201 defsubr (&Sinteractive_form
);
3204 defsubr (&Stype_of
);
3209 defsubr (&Sintegerp
);
3210 defsubr (&Sinteger_or_marker_p
);
3211 defsubr (&Snumberp
);
3212 defsubr (&Snumber_or_marker_p
);
3214 defsubr (&Snatnump
);
3215 defsubr (&Ssymbolp
);
3216 defsubr (&Skeywordp
);
3217 defsubr (&Sstringp
);
3218 defsubr (&Smultibyte_string_p
);
3219 defsubr (&Svectorp
);
3220 defsubr (&Schar_table_p
);
3221 defsubr (&Svector_or_char_table_p
);
3222 defsubr (&Sbool_vector_p
);
3224 defsubr (&Ssequencep
);
3225 defsubr (&Sbufferp
);
3226 defsubr (&Smarkerp
);
3228 defsubr (&Sbyte_code_function_p
);
3229 defsubr (&Schar_or_string_p
);
3232 defsubr (&Scar_safe
);
3233 defsubr (&Scdr_safe
);
3236 defsubr (&Ssymbol_function
);
3237 defsubr (&Sindirect_function
);
3238 defsubr (&Ssymbol_plist
);
3239 defsubr (&Ssymbol_name
);
3240 defsubr (&Smakunbound
);
3241 defsubr (&Sfmakunbound
);
3243 defsubr (&Sfboundp
);
3245 defsubr (&Sdefalias
);
3246 defsubr (&Ssetplist
);
3247 defsubr (&Ssymbol_value
);
3249 defsubr (&Sdefault_boundp
);
3250 defsubr (&Sdefault_value
);
3251 defsubr (&Sset_default
);
3252 defsubr (&Ssetq_default
);
3253 defsubr (&Smake_variable_buffer_local
);
3254 defsubr (&Smake_local_variable
);
3255 defsubr (&Skill_local_variable
);
3256 defsubr (&Smake_variable_frame_local
);
3257 defsubr (&Slocal_variable_p
);
3258 defsubr (&Slocal_variable_if_set_p
);
3259 defsubr (&Svariable_binding_locus
);
3260 #if 0 /* XXX Remove this. --lorentey */
3261 defsubr (&Sterminal_local_value
);
3262 defsubr (&Sset_terminal_local_value
);
3266 defsubr (&Snumber_to_string
);
3267 defsubr (&Sstring_to_number
);
3268 defsubr (&Seqlsign
);
3291 defsubr (&Sbyteorder
);
3292 defsubr (&Ssubr_arity
);
3293 defsubr (&Ssubr_name
);
3295 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3297 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3298 doc
: /* The largest value that is representable in a Lisp integer. */);
3299 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3300 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3302 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3303 doc
: /* The smallest value that is representable in a Lisp integer. */);
3304 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3305 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3309 arith_error (int signo
)
3311 sigsetmask (SIGEMPTYMASK
);
3313 SIGNAL_THREAD_CHECK (signo
);
3314 xsignal0 (Qarith_error
);
3320 /* Don't do this if just dumping out.
3321 We don't want to call `signal' in this case
3322 so that we don't have trouble with dumping
3323 signal-delivering routines in an inconsistent state. */
3327 #endif /* CANNOT_DUMP */
3328 signal (SIGFPE
, arith_error
);
3331 signal (SIGEMT
, arith_error
);