1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 #include "character.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
46 #define IEEE_FLOATING_POINT 0
53 extern double atof (const char *);
56 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
57 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
58 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
59 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
60 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
61 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
62 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
63 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
64 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
65 Lisp_Object Qtext_read_only
;
67 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
68 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
69 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
70 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
71 Lisp_Object Qboundp
, Qfboundp
;
72 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
75 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
77 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
78 Lisp_Object Qoverflow_error
, Qunderflow_error
;
81 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
84 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
86 static Lisp_Object Qfloat
, Qwindow_configuration
;
88 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
89 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
90 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
91 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
93 Lisp_Object Qinteractive_form
;
95 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
99 circular_list_error (Lisp_Object list
)
101 xsignal (Qcircular_list
, list
);
106 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
108 /* If VALUE is not even a valid Lisp object, we'd want to abort here
109 where we can get a backtrace showing where it came from. We used
110 to try and do that by checking the tagbits, but nowadays all
111 tagbits are potentially valid. */
112 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
115 xsignal2 (Qwrong_type_argument
, predicate
, value
);
119 pure_write_error (void)
121 error ("Attempt to modify read-only object");
125 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
127 xsignal2 (Qargs_out_of_range
, a1
, a2
);
131 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
133 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
137 /* Data type predicates */
139 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
140 doc
: /* Return t if the two args are the same Lisp object. */)
141 (Lisp_Object obj1
, Lisp_Object obj2
)
148 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
149 doc
: /* Return t if OBJECT is nil. */)
157 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
158 doc
: /* Return a symbol representing the type of OBJECT.
159 The symbol returned names the object's basic type;
160 for example, (type-of 1) returns `integer'. */)
163 switch (XTYPE (object
))
178 switch (XMISCTYPE (object
))
180 case Lisp_Misc_Marker
:
182 case Lisp_Misc_Overlay
:
184 case Lisp_Misc_Float
:
189 case Lisp_Vectorlike
:
190 if (WINDOW_CONFIGURATIONP (object
))
191 return Qwindow_configuration
;
192 if (PROCESSP (object
))
194 if (WINDOWP (object
))
198 if (COMPILEDP (object
))
199 return Qcompiled_function
;
200 if (BUFFERP (object
))
202 if (CHAR_TABLE_P (object
))
204 if (BOOL_VECTOR_P (object
))
208 if (HASH_TABLE_P (object
))
210 if (FONT_SPEC_P (object
))
212 if (FONT_ENTITY_P (object
))
214 if (FONT_OBJECT_P (object
))
226 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
227 doc
: /* Return t if OBJECT is a cons cell. */)
235 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
236 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
244 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
245 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
246 Otherwise, return nil. */)
249 if (CONSP (object
) || NILP (object
))
254 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
255 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
258 if (CONSP (object
) || NILP (object
))
263 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
264 doc
: /* Return t if OBJECT is a symbol. */)
267 if (SYMBOLP (object
))
272 /* Define this in C to avoid unnecessarily consing up the symbol
274 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
275 doc
: /* Return t if OBJECT is a keyword.
276 This means that it is a symbol with a print name beginning with `:'
277 interned in the initial obarray. */)
281 && SREF (SYMBOL_NAME (object
), 0) == ':'
282 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
287 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
288 doc
: /* Return t if OBJECT is a vector. */)
291 if (VECTORP (object
))
296 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
297 doc
: /* Return t if OBJECT is a string. */)
300 if (STRINGP (object
))
305 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
307 doc
: /* Return t if OBJECT is a multibyte string. */)
310 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
315 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is a char-table. */)
319 if (CHAR_TABLE_P (object
))
324 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
325 Svector_or_char_table_p
, 1, 1, 0,
326 doc
: /* Return t if OBJECT is a char-table or vector. */)
329 if (VECTORP (object
) || CHAR_TABLE_P (object
))
334 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
335 doc
: /* Return t if OBJECT is a bool-vector. */)
338 if (BOOL_VECTOR_P (object
))
343 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
344 doc
: /* Return t if OBJECT is an array (string or vector). */)
352 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
353 doc
: /* Return t if OBJECT is a sequence (list or array). */)
354 (register Lisp_Object object
)
356 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
361 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
362 doc
: /* Return t if OBJECT is an editor buffer. */)
365 if (BUFFERP (object
))
370 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
371 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
374 if (MARKERP (object
))
379 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
380 doc
: /* Return t if OBJECT is a built-in function. */)
388 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
390 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
393 if (COMPILEDP (object
))
398 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
399 doc
: /* Return t if OBJECT is a character or a string. */)
400 (register Lisp_Object object
)
402 if (CHARACTERP (object
) || STRINGP (object
))
407 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is an integer. */)
411 if (INTEGERP (object
))
416 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
417 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
418 (register Lisp_Object object
)
420 if (MARKERP (object
) || INTEGERP (object
))
425 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
426 doc
: /* Return t if OBJECT is a nonnegative integer. */)
429 if (NATNUMP (object
))
434 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
435 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
438 if (NUMBERP (object
))
444 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
445 Snumber_or_marker_p
, 1, 1, 0,
446 doc
: /* Return t if OBJECT is a number or a marker. */)
449 if (NUMBERP (object
) || MARKERP (object
))
454 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
455 doc
: /* Return t if OBJECT is a floating point number. */)
464 /* Extract and set components of lists */
466 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
467 doc
: /* Return the car of LIST. If arg is nil, return nil.
468 Error if arg is not nil and not a cons cell. See also `car-safe'.
470 See Info node `(elisp)Cons Cells' for a discussion of related basic
471 Lisp concepts such as car, cdr, cons cell and list. */)
472 (register Lisp_Object list
)
477 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
478 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
481 return CAR_SAFE (object
);
484 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
485 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
486 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
488 See Info node `(elisp)Cons Cells' for a discussion of related basic
489 Lisp concepts such as cdr, car, cons cell and list. */)
490 (register Lisp_Object list
)
495 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
496 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
499 return CDR_SAFE (object
);
502 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
503 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
504 (register Lisp_Object cell
, Lisp_Object newcar
)
508 XSETCAR (cell
, newcar
);
512 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
513 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
514 (register Lisp_Object cell
, Lisp_Object newcdr
)
518 XSETCDR (cell
, newcdr
);
522 /* Extract and set components of symbols */
524 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
525 doc
: /* Return t if SYMBOL's value is not void. */)
526 (register Lisp_Object symbol
)
528 Lisp_Object valcontents
;
529 struct Lisp_Symbol
*sym
;
530 CHECK_SYMBOL (symbol
);
531 sym
= XSYMBOL (symbol
);
534 switch (sym
->redirect
)
536 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
537 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
538 case SYMBOL_LOCALIZED
:
540 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
542 /* In set_internal, we un-forward vars when their value is
547 swap_in_symval_forwarding (sym
, blv
);
548 valcontents
= BLV_VALUE (blv
);
552 case SYMBOL_FORWARDED
:
553 /* In set_internal, we un-forward vars when their value is
559 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
562 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
563 doc
: /* Return t if SYMBOL's function definition is not void. */)
564 (register Lisp_Object symbol
)
566 CHECK_SYMBOL (symbol
);
567 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
570 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
571 doc
: /* Make SYMBOL's value be void.
573 (register Lisp_Object symbol
)
575 CHECK_SYMBOL (symbol
);
576 if (SYMBOL_CONSTANT_P (symbol
))
577 xsignal1 (Qsetting_constant
, symbol
);
578 Fset (symbol
, Qunbound
);
582 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
583 doc
: /* Make SYMBOL's function definition be void.
585 (register Lisp_Object symbol
)
587 CHECK_SYMBOL (symbol
);
588 if (NILP (symbol
) || EQ (symbol
, Qt
))
589 xsignal1 (Qsetting_constant
, symbol
);
590 XSYMBOL (symbol
)->function
= Qunbound
;
594 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
595 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
596 (register Lisp_Object symbol
)
598 CHECK_SYMBOL (symbol
);
599 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
600 return XSYMBOL (symbol
)->function
;
601 xsignal1 (Qvoid_function
, symbol
);
604 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
605 doc
: /* Return SYMBOL's property list. */)
606 (register Lisp_Object symbol
)
608 CHECK_SYMBOL (symbol
);
609 return XSYMBOL (symbol
)->plist
;
612 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
613 doc
: /* Return SYMBOL's name, a string. */)
614 (register Lisp_Object symbol
)
616 register Lisp_Object name
;
618 CHECK_SYMBOL (symbol
);
619 name
= SYMBOL_NAME (symbol
);
623 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
624 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
625 (register Lisp_Object symbol
, Lisp_Object definition
)
627 register Lisp_Object function
;
629 CHECK_SYMBOL (symbol
);
630 if (NILP (symbol
) || EQ (symbol
, Qt
))
631 xsignal1 (Qsetting_constant
, symbol
);
633 function
= XSYMBOL (symbol
)->function
;
635 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
636 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
638 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
639 Fput (symbol
, Qautoload
, XCDR (function
));
641 XSYMBOL (symbol
)->function
= definition
;
642 /* Handle automatic advice activation */
643 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
645 call2 (Qad_activate_internal
, symbol
, Qnil
);
646 definition
= XSYMBOL (symbol
)->function
;
651 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
652 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
653 Associates the function with the current load file, if any.
654 The optional third argument DOCSTRING specifies the documentation string
655 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
656 determined by DEFINITION. */)
657 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
659 CHECK_SYMBOL (symbol
);
660 if (CONSP (XSYMBOL (symbol
)->function
)
661 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
662 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
663 definition
= Ffset (symbol
, definition
);
664 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
665 if (!NILP (docstring
))
666 Fput (symbol
, Qfunction_documentation
, docstring
);
670 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
671 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
672 (register Lisp_Object symbol
, Lisp_Object newplist
)
674 CHECK_SYMBOL (symbol
);
675 XSYMBOL (symbol
)->plist
= newplist
;
679 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
680 doc
: /* Return minimum and maximum number of args allowed for SUBR.
681 SUBR must be a built-in function.
682 The returned value is a pair (MIN . MAX). MIN is the minimum number
683 of args. MAX is the maximum number or the symbol `many', for a
684 function with `&rest' args, or `unevalled' for a special form. */)
687 short minargs
, maxargs
;
689 minargs
= XSUBR (subr
)->min_args
;
690 maxargs
= XSUBR (subr
)->max_args
;
692 return Fcons (make_number (minargs
), Qmany
);
693 else if (maxargs
== UNEVALLED
)
694 return Fcons (make_number (minargs
), Qunevalled
);
696 return Fcons (make_number (minargs
), make_number (maxargs
));
699 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
700 doc
: /* Return name of subroutine SUBR.
701 SUBR must be a built-in function. */)
706 name
= XSUBR (subr
)->symbol_name
;
707 return make_string (name
, strlen (name
));
710 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
711 doc
: /* Return the interactive form of CMD or nil if none.
712 If CMD is not a command, the return value is nil.
713 Value, if non-nil, is a list \(interactive SPEC). */)
716 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
718 if (NILP (fun
) || EQ (fun
, Qunbound
))
721 /* Use an `interactive-form' property if present, analogous to the
722 function-documentation property. */
724 while (SYMBOLP (fun
))
726 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
730 fun
= Fsymbol_function (fun
);
735 const char *spec
= XSUBR (fun
)->intspec
;
737 return list2 (Qinteractive
,
738 (*spec
!= '(') ? build_string (spec
) :
739 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
741 else if (COMPILEDP (fun
))
743 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
744 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
746 else if (CONSP (fun
))
748 Lisp_Object funcar
= XCAR (fun
);
749 if (EQ (funcar
, Qlambda
))
750 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
751 else if (EQ (funcar
, Qautoload
))
755 do_autoload (fun
, cmd
);
757 return Finteractive_form (cmd
);
764 /***********************************************************************
765 Getting and Setting Values of Symbols
766 ***********************************************************************/
768 /* Return the symbol holding SYMBOL's value. Signal
769 `cyclic-variable-indirection' if SYMBOL's chain of variable
770 indirections contains a loop. */
773 indirect_variable (struct Lisp_Symbol
*symbol
)
775 struct Lisp_Symbol
*tortoise
, *hare
;
777 hare
= tortoise
= symbol
;
779 while (hare
->redirect
== SYMBOL_VARALIAS
)
781 hare
= SYMBOL_ALIAS (hare
);
782 if (hare
->redirect
!= SYMBOL_VARALIAS
)
785 hare
= SYMBOL_ALIAS (hare
);
786 tortoise
= SYMBOL_ALIAS (tortoise
);
788 if (hare
== tortoise
)
791 XSETSYMBOL (tem
, symbol
);
792 xsignal1 (Qcyclic_variable_indirection
, tem
);
800 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
801 doc
: /* Return the variable at the end of OBJECT's variable chain.
802 If OBJECT is a symbol, follow all variable indirections and return the final
803 variable. If OBJECT is not a symbol, just return it.
804 Signal a cyclic-variable-indirection error if there is a loop in the
805 variable chain of symbols. */)
808 if (SYMBOLP (object
))
809 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
814 /* Given the raw contents of a symbol value cell,
815 return the Lisp value of the symbol.
816 This does not handle buffer-local variables; use
817 swap_in_symval_forwarding for that. */
819 #define do_blv_forwarding(blv) \
820 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
823 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
825 register Lisp_Object val
;
826 switch (XFWDTYPE (valcontents
))
829 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
833 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
836 return *XOBJFWD (valcontents
)->objvar
;
838 case Lisp_Fwd_Buffer_Obj
:
839 return PER_BUFFER_VALUE (current_buffer
,
840 XBUFFER_OBJFWD (valcontents
)->offset
);
842 case Lisp_Fwd_Kboard_Obj
:
843 /* We used to simply use current_kboard here, but from Lisp
844 code, it's value is often unexpected. It seems nicer to
845 allow constructions like this to work as intuitively expected:
847 (with-selected-frame frame
848 (define-key local-function-map "\eOP" [f1]))
850 On the other hand, this affects the semantics of
851 last-command and real-last-command, and people may rely on
852 that. I took a quick look at the Lisp codebase, and I
853 don't think anything will break. --lorentey */
854 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
855 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
860 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
861 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
862 buffer-independent contents of the value cell: forwarded just one
863 step past the buffer-localness.
865 BUF non-zero means set the value in buffer BUF instead of the
866 current buffer. This only plays a role for per-buffer variables. */
868 #define store_blv_forwarding(blv, newval, buf) \
870 if ((blv)->forwarded) \
871 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
873 SET_BLV_VALUE (blv, newval); \
877 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
879 switch (XFWDTYPE (valcontents
))
882 CHECK_NUMBER (newval
);
883 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
887 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
891 *XOBJFWD (valcontents
)->objvar
= newval
;
893 /* If this variable is a default for something stored
894 in the buffer itself, such as default-fill-column,
895 find the buffers that don't have local values for it
897 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
898 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
900 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
901 - (char *) &buffer_defaults
);
902 int idx
= PER_BUFFER_IDX (offset
);
909 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
914 buf
= Fcdr (XCAR (tail
));
915 if (!BUFFERP (buf
)) continue;
918 if (! PER_BUFFER_VALUE_P (b
, idx
))
919 PER_BUFFER_VALUE (b
, offset
) = newval
;
924 case Lisp_Fwd_Buffer_Obj
:
926 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
927 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
929 if (!(NILP (type
) || NILP (newval
)
930 || (XINT (type
) == LISP_INT_TAG
932 : XTYPE (newval
) == XINT (type
))))
933 buffer_slot_type_mismatch (newval
, XINT (type
));
936 buf
= current_buffer
;
937 PER_BUFFER_VALUE (buf
, offset
) = newval
;
941 case Lisp_Fwd_Kboard_Obj
:
943 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
944 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
945 *(Lisp_Object
*) p
= newval
;
950 abort (); /* goto def; */
954 /* Set up SYMBOL to refer to its global binding.
955 This makes it safe to alter the status of other bindings. */
958 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
960 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
962 /* Unload the previously loaded binding. */
964 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
966 /* Select the global binding in the symbol. */
967 blv
->valcell
= blv
->defcell
;
969 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
971 /* Indicate that the global binding is set up now. */
973 SET_BLV_FOUND (blv
, 0);
976 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
977 VALCONTENTS is the contents of its value cell,
978 which points to a struct Lisp_Buffer_Local_Value.
980 Return the value forwarded one step past the buffer-local stage.
981 This could be another forwarding pointer. */
984 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
986 register Lisp_Object tem1
;
988 eassert (blv
== SYMBOL_BLV (symbol
));
994 ? !EQ (selected_frame
, tem1
)
995 : current_buffer
!= XBUFFER (tem1
)))
998 /* Unload the previously loaded binding. */
1001 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1002 /* Choose the new binding. */
1005 XSETSYMBOL (var
, symbol
);
1006 if (blv
->frame_local
)
1008 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1009 blv
->where
= selected_frame
;
1013 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1014 XSETBUFFER (blv
->where
, current_buffer
);
1017 if (!(blv
->found
= !NILP (tem1
)))
1018 tem1
= blv
->defcell
;
1020 /* Load the new binding. */
1021 blv
->valcell
= tem1
;
1023 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1027 /* Find the value of a symbol, returning Qunbound if it's not bound.
1028 This is helpful for code which just wants to get a variable's value
1029 if it has one, without signaling an error.
1030 Note that it must not be possible to quit
1031 within this function. Great care is required for this. */
1034 find_symbol_value (Lisp_Object symbol
)
1036 struct Lisp_Symbol
*sym
;
1038 CHECK_SYMBOL (symbol
);
1039 sym
= XSYMBOL (symbol
);
1042 switch (sym
->redirect
)
1044 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1045 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1046 case SYMBOL_LOCALIZED
:
1048 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1049 swap_in_symval_forwarding (sym
, blv
);
1050 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1053 case SYMBOL_FORWARDED
:
1054 return do_symval_forwarding (SYMBOL_FWD (sym
));
1059 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1060 doc
: /* Return SYMBOL's value. Error if that is void. */)
1061 (Lisp_Object symbol
)
1065 val
= find_symbol_value (symbol
);
1066 if (!EQ (val
, Qunbound
))
1069 xsignal1 (Qvoid_variable
, symbol
);
1072 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1073 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1074 (register Lisp_Object symbol
, Lisp_Object newval
)
1076 set_internal (symbol
, newval
, Qnil
, 0);
1080 /* Return 1 if SYMBOL currently has a let-binding
1081 which was made in the buffer that is now current. */
1084 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1086 struct specbinding
*p
;
1088 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1090 && CONSP (p
->symbol
))
1092 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1093 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1094 if (symbol
== let_bound_symbol
1095 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1099 return p
>= specpdl
;
1103 let_shadows_global_binding_p (Lisp_Object symbol
)
1105 struct specbinding
*p
;
1107 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1108 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1111 return p
>= specpdl
;
1114 /* Store the value NEWVAL into SYMBOL.
1115 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1116 (nil stands for the current buffer/frame).
1118 If BINDFLAG is zero, then if this symbol is supposed to become
1119 local in every buffer where it is set, then we make it local.
1120 If BINDFLAG is nonzero, we don't do that. */
1123 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1125 int voide
= EQ (newval
, Qunbound
);
1126 struct Lisp_Symbol
*sym
;
1129 /* If restoring in a dead buffer, do nothing. */
1130 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1133 CHECK_SYMBOL (symbol
);
1134 if (SYMBOL_CONSTANT_P (symbol
))
1136 if (NILP (Fkeywordp (symbol
))
1137 || !EQ (newval
, Fsymbol_value (symbol
)))
1138 xsignal1 (Qsetting_constant
, symbol
);
1140 /* Allow setting keywords to their own value. */
1144 sym
= XSYMBOL (symbol
);
1147 switch (sym
->redirect
)
1149 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1150 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1151 case SYMBOL_LOCALIZED
:
1153 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1156 if (blv
->frame_local
)
1157 where
= selected_frame
;
1159 XSETBUFFER (where
, current_buffer
);
1161 /* If the current buffer is not the buffer whose binding is
1162 loaded, or if there may be frame-local bindings and the frame
1163 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1164 the default binding is loaded, the loaded binding may be the
1166 if (!EQ (blv
->where
, where
)
1167 /* Also unload a global binding (if the var is local_if_set). */
1168 || (EQ (blv
->valcell
, blv
->defcell
)))
1170 /* The currently loaded binding is not necessarily valid.
1171 We need to unload it, and choose a new binding. */
1173 /* Write out `realvalue' to the old loaded binding. */
1175 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1177 /* Find the new binding. */
1178 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1179 tem1
= Fassq (symbol
,
1181 ? XFRAME (where
)->param_alist
1182 : XBUFFER (where
)->local_var_alist
));
1188 /* This buffer still sees the default value. */
1190 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1191 or if this is `let' rather than `set',
1192 make CURRENT-ALIST-ELEMENT point to itself,
1193 indicating that we're seeing the default value.
1194 Likewise if the variable has been let-bound
1195 in the current buffer. */
1196 if (bindflag
|| !blv
->local_if_set
1197 || let_shadows_buffer_binding_p (sym
))
1200 tem1
= blv
->defcell
;
1202 /* If it's a local_if_set, being set not bound,
1203 and we're not within a let that was made for this buffer,
1204 create a new buffer-local binding for the variable.
1205 That means, give this buffer a new assoc for a local value
1206 and load that binding. */
1209 /* local_if_set is only supported for buffer-local
1210 bindings, not for frame-local bindings. */
1211 eassert (!blv
->frame_local
);
1212 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1213 XBUFFER (where
)->local_var_alist
1214 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1218 /* Record which binding is now loaded. */
1219 blv
->valcell
= tem1
;
1222 /* Store the new value in the cons cell. */
1223 SET_BLV_VALUE (blv
, newval
);
1228 /* If storing void (making the symbol void), forward only through
1229 buffer-local indicator, not through Lisp_Objfwd, etc. */
1232 store_symval_forwarding (blv
->fwd
, newval
,
1234 ? XBUFFER (where
) : current_buffer
);
1238 case SYMBOL_FORWARDED
:
1241 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1242 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1243 if (BUFFER_OBJFWDP (innercontents
))
1245 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1246 int idx
= PER_BUFFER_IDX (offset
);
1249 && !let_shadows_buffer_binding_p (sym
))
1250 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1254 { /* If storing void (making the symbol void), forward only through
1255 buffer-local indicator, not through Lisp_Objfwd, etc. */
1256 sym
->redirect
= SYMBOL_PLAINVAL
;
1257 SET_SYMBOL_VAL (sym
, newval
);
1260 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1268 /* Access or set a buffer-local symbol's default value. */
1270 /* Return the default value of SYMBOL, but don't check for voidness.
1271 Return Qunbound if it is void. */
1274 default_value (Lisp_Object symbol
)
1276 struct Lisp_Symbol
*sym
;
1278 CHECK_SYMBOL (symbol
);
1279 sym
= XSYMBOL (symbol
);
1282 switch (sym
->redirect
)
1284 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1285 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1286 case SYMBOL_LOCALIZED
:
1288 /* If var is set up for a buffer that lacks a local value for it,
1289 the current value is nominally the default value.
1290 But the `realvalue' slot may be more up to date, since
1291 ordinary setq stores just that slot. So use that. */
1292 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1293 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1294 return do_symval_forwarding (blv
->fwd
);
1296 return XCDR (blv
->defcell
);
1298 case SYMBOL_FORWARDED
:
1300 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1302 /* For a built-in buffer-local variable, get the default value
1303 rather than letting do_symval_forwarding get the current value. */
1304 if (BUFFER_OBJFWDP (valcontents
))
1306 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1307 if (PER_BUFFER_IDX (offset
) != 0)
1308 return PER_BUFFER_DEFAULT (offset
);
1311 /* For other variables, get the current value. */
1312 return do_symval_forwarding (valcontents
);
1318 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1319 doc
: /* Return t if SYMBOL has a non-void default value.
1320 This is the value that is seen in buffers that do not have their own values
1321 for this variable. */)
1322 (Lisp_Object symbol
)
1324 register Lisp_Object value
;
1326 value
= default_value (symbol
);
1327 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1330 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1331 doc
: /* Return SYMBOL's default value.
1332 This is the value that is seen in buffers that do not have their own values
1333 for this variable. The default value is meaningful for variables with
1334 local bindings in certain buffers. */)
1335 (Lisp_Object symbol
)
1337 register Lisp_Object value
;
1339 value
= default_value (symbol
);
1340 if (!EQ (value
, Qunbound
))
1343 xsignal1 (Qvoid_variable
, symbol
);
1346 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1347 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1348 The default value is seen in buffers that do not have their own values
1349 for this variable. */)
1350 (Lisp_Object symbol
, Lisp_Object value
)
1352 struct Lisp_Symbol
*sym
;
1354 CHECK_SYMBOL (symbol
);
1355 if (SYMBOL_CONSTANT_P (symbol
))
1357 if (NILP (Fkeywordp (symbol
))
1358 || !EQ (value
, Fdefault_value (symbol
)))
1359 xsignal1 (Qsetting_constant
, symbol
);
1361 /* Allow setting keywords to their own value. */
1364 sym
= XSYMBOL (symbol
);
1367 switch (sym
->redirect
)
1369 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1370 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1371 case SYMBOL_LOCALIZED
:
1373 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1375 /* Store new value into the DEFAULT-VALUE slot. */
1376 XSETCDR (blv
->defcell
, value
);
1378 /* If the default binding is now loaded, set the REALVALUE slot too. */
1379 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1380 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1383 case SYMBOL_FORWARDED
:
1385 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1387 /* Handle variables like case-fold-search that have special slots
1389 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1390 if (BUFFER_OBJFWDP (valcontents
))
1392 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1393 int idx
= PER_BUFFER_IDX (offset
);
1395 PER_BUFFER_DEFAULT (offset
) = value
;
1397 /* If this variable is not always local in all buffers,
1398 set it in the buffers that don't nominally have a local value. */
1403 for (b
= all_buffers
; b
; b
= b
->next
)
1404 if (!PER_BUFFER_VALUE_P (b
, idx
))
1405 PER_BUFFER_VALUE (b
, offset
) = value
;
1410 return Fset (symbol
, value
);
1416 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1417 doc
: /* Set the default value of variable VAR to VALUE.
1418 VAR, the variable name, is literal (not evaluated);
1419 VALUE is an expression: it is evaluated and its value returned.
1420 The default value of a variable is seen in buffers
1421 that do not have their own values for the variable.
1423 More generally, you can use multiple variables and values, as in
1424 (setq-default VAR VALUE VAR VALUE...)
1425 This sets each VAR's default value to the corresponding VALUE.
1426 The VALUE for the Nth VAR can refer to the new default values
1428 usage: (setq-default [VAR VALUE]...) */)
1431 register Lisp_Object args_left
;
1432 register Lisp_Object val
, symbol
;
1433 struct gcpro gcpro1
;
1443 val
= Feval (Fcar (Fcdr (args_left
)));
1444 symbol
= XCAR (args_left
);
1445 Fset_default (symbol
, val
);
1446 args_left
= Fcdr (XCDR (args_left
));
1448 while (!NILP (args_left
));
1454 /* Lisp functions for creating and removing buffer-local variables. */
1459 union Lisp_Fwd
*fwd
;
1462 static struct Lisp_Buffer_Local_Value
*
1463 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1465 struct Lisp_Buffer_Local_Value
*blv
1466 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1470 XSETSYMBOL (symbol
, sym
);
1471 tem
= Fcons (symbol
, (forwarded
1472 ? do_symval_forwarding (valcontents
.fwd
)
1473 : valcontents
.value
));
1475 /* Buffer_Local_Values cannot have as realval a buffer-local
1476 or keyboard-local forwarding. */
1477 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1478 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1479 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1481 blv
->frame_local
= 0;
1482 blv
->local_if_set
= 0;
1485 SET_BLV_FOUND (blv
, 0);
1489 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1490 1, 1, "vMake Variable Buffer Local: ",
1491 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1492 At any time, the value for the current buffer is in effect,
1493 unless the variable has never been set in this buffer,
1494 in which case the default value is in effect.
1495 Note that binding the variable with `let', or setting it while
1496 a `let'-style binding made in this buffer is in effect,
1497 does not make the variable buffer-local. Return VARIABLE.
1499 In most cases it is better to use `make-local-variable',
1500 which makes a variable local in just one buffer.
1502 The function `default-value' gets the default value and `set-default' sets it. */)
1503 (register Lisp_Object variable
)
1505 struct Lisp_Symbol
*sym
;
1506 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1507 union Lisp_Val_Fwd valcontents
;
1510 CHECK_SYMBOL (variable
);
1511 sym
= XSYMBOL (variable
);
1514 switch (sym
->redirect
)
1516 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1517 case SYMBOL_PLAINVAL
:
1518 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1519 if (EQ (valcontents
.value
, Qunbound
))
1520 valcontents
.value
= Qnil
;
1522 case SYMBOL_LOCALIZED
:
1523 blv
= SYMBOL_BLV (sym
);
1524 if (blv
->frame_local
)
1525 error ("Symbol %s may not be buffer-local",
1526 SDATA (SYMBOL_NAME (variable
)));
1528 case SYMBOL_FORWARDED
:
1529 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1530 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1531 error ("Symbol %s may not be buffer-local",
1532 SDATA (SYMBOL_NAME (variable
)));
1533 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1540 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1544 blv
= make_blv (sym
, forwarded
, valcontents
);
1545 sym
->redirect
= SYMBOL_LOCALIZED
;
1546 SET_SYMBOL_BLV (sym
, blv
);
1549 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1550 if (let_shadows_global_binding_p (symbol
))
1551 message ("Making %s buffer-local while let-bound!",
1552 SDATA (SYMBOL_NAME (variable
)));
1556 blv
->local_if_set
= 1;
1560 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1561 1, 1, "vMake Local Variable: ",
1562 doc
: /* Make VARIABLE have a separate value in the current buffer.
1563 Other buffers will continue to share a common default value.
1564 \(The buffer-local value of VARIABLE starts out as the same value
1565 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1568 If the variable is already arranged to become local when set,
1569 this function causes a local value to exist for this buffer,
1570 just as setting the variable would do.
1572 This function returns VARIABLE, and therefore
1573 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1576 See also `make-variable-buffer-local'.
1578 Do not use `make-local-variable' to make a hook variable buffer-local.
1579 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1580 (register Lisp_Object variable
)
1582 register Lisp_Object tem
;
1584 union Lisp_Val_Fwd valcontents
;
1585 struct Lisp_Symbol
*sym
;
1586 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1588 CHECK_SYMBOL (variable
);
1589 sym
= XSYMBOL (variable
);
1592 switch (sym
->redirect
)
1594 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1595 case SYMBOL_PLAINVAL
:
1596 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1597 case SYMBOL_LOCALIZED
:
1598 blv
= SYMBOL_BLV (sym
);
1599 if (blv
->frame_local
)
1600 error ("Symbol %s may not be buffer-local",
1601 SDATA (SYMBOL_NAME (variable
)));
1603 case SYMBOL_FORWARDED
:
1604 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1605 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1606 error ("Symbol %s may not be buffer-local",
1607 SDATA (SYMBOL_NAME (variable
)));
1613 error ("Symbol %s may not be buffer-local",
1614 SDATA (SYMBOL_NAME (variable
)));
1616 if (blv
? blv
->local_if_set
1617 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1619 tem
= Fboundp (variable
);
1620 /* Make sure the symbol has a local value in this particular buffer,
1621 by setting it to the same value it already has. */
1622 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1627 blv
= make_blv (sym
, forwarded
, valcontents
);
1628 sym
->redirect
= SYMBOL_LOCALIZED
;
1629 SET_SYMBOL_BLV (sym
, blv
);
1632 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1633 if (let_shadows_global_binding_p (symbol
))
1634 message ("Making %s local to %s while let-bound!",
1635 SDATA (SYMBOL_NAME (variable
)),
1636 SDATA (current_buffer
->name
));
1640 /* Make sure this buffer has its own value of symbol. */
1641 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1642 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1645 if (let_shadows_buffer_binding_p (sym
))
1646 message ("Making %s buffer-local while locally let-bound!",
1647 SDATA (SYMBOL_NAME (variable
)));
1649 /* Swap out any local binding for some other buffer, and make
1650 sure the current value is permanently recorded, if it's the
1652 find_symbol_value (variable
);
1654 current_buffer
->local_var_alist
1655 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1656 current_buffer
->local_var_alist
);
1658 /* Make sure symbol does not think it is set up for this buffer;
1659 force it to look once again for this buffer's value. */
1660 if (current_buffer
== XBUFFER (blv
->where
))
1662 /* blv->valcell = blv->defcell;
1663 * SET_BLV_FOUND (blv, 0); */
1667 /* If the symbol forwards into a C variable, then load the binding
1668 for this buffer now. If C code modifies the variable before we
1669 load the binding in, then that new value will clobber the default
1670 binding the next time we unload it. */
1672 swap_in_symval_forwarding (sym
, blv
);
1677 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1678 1, 1, "vKill Local Variable: ",
1679 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1680 From now on the default value will apply in this buffer. Return VARIABLE. */)
1681 (register Lisp_Object variable
)
1683 register Lisp_Object tem
;
1684 struct Lisp_Buffer_Local_Value
*blv
;
1685 struct Lisp_Symbol
*sym
;
1687 CHECK_SYMBOL (variable
);
1688 sym
= XSYMBOL (variable
);
1691 switch (sym
->redirect
)
1693 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1694 case SYMBOL_PLAINVAL
: return variable
;
1695 case SYMBOL_FORWARDED
:
1697 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1698 if (BUFFER_OBJFWDP (valcontents
))
1700 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1701 int idx
= PER_BUFFER_IDX (offset
);
1705 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1706 PER_BUFFER_VALUE (current_buffer
, offset
)
1707 = PER_BUFFER_DEFAULT (offset
);
1712 case SYMBOL_LOCALIZED
:
1713 blv
= SYMBOL_BLV (sym
);
1714 if (blv
->frame_local
)
1720 /* Get rid of this buffer's alist element, if any. */
1721 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1722 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1724 current_buffer
->local_var_alist
1725 = Fdelq (tem
, current_buffer
->local_var_alist
);
1727 /* If the symbol is set up with the current buffer's binding
1728 loaded, recompute its value. We have to do it now, or else
1729 forwarded objects won't work right. */
1731 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1732 if (EQ (buf
, blv
->where
))
1735 /* blv->valcell = blv->defcell;
1736 * SET_BLV_FOUND (blv, 0); */
1738 find_symbol_value (variable
);
1745 /* Lisp functions for creating and removing buffer-local variables. */
1747 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1748 when/if this is removed. */
1750 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1751 1, 1, "vMake Variable Frame Local: ",
1752 doc
: /* Enable VARIABLE to have frame-local bindings.
1753 This does not create any frame-local bindings for VARIABLE,
1754 it just makes them possible.
1756 A frame-local binding is actually a frame parameter value.
1757 If a frame F has a value for the frame parameter named VARIABLE,
1758 that also acts as a frame-local binding for VARIABLE in F--
1759 provided this function has been called to enable VARIABLE
1760 to have frame-local bindings at all.
1762 The only way to create a frame-local binding for VARIABLE in a frame
1763 is to set the VARIABLE frame parameter of that frame. See
1764 `modify-frame-parameters' for how to set frame parameters.
1766 Note that since Emacs 23.1, variables cannot be both buffer-local and
1767 frame-local any more (buffer-local bindings used to take precedence over
1768 frame-local bindings). */)
1769 (register Lisp_Object variable
)
1772 union Lisp_Val_Fwd valcontents
;
1773 struct Lisp_Symbol
*sym
;
1774 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1776 CHECK_SYMBOL (variable
);
1777 sym
= XSYMBOL (variable
);
1780 switch (sym
->redirect
)
1782 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1783 case SYMBOL_PLAINVAL
:
1784 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1785 if (EQ (valcontents
.value
, Qunbound
))
1786 valcontents
.value
= Qnil
;
1788 case SYMBOL_LOCALIZED
:
1789 if (SYMBOL_BLV (sym
)->frame_local
)
1792 error ("Symbol %s may not be frame-local",
1793 SDATA (SYMBOL_NAME (variable
)));
1794 case SYMBOL_FORWARDED
:
1795 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1796 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1797 error ("Symbol %s may not be frame-local",
1798 SDATA (SYMBOL_NAME (variable
)));
1804 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1806 blv
= make_blv (sym
, forwarded
, valcontents
);
1807 blv
->frame_local
= 1;
1808 sym
->redirect
= SYMBOL_LOCALIZED
;
1809 SET_SYMBOL_BLV (sym
, blv
);
1812 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1813 if (let_shadows_global_binding_p (symbol
))
1814 message ("Making %s frame-local while let-bound!",
1815 SDATA (SYMBOL_NAME (variable
)));
1820 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1822 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1823 BUFFER defaults to the current buffer. */)
1824 (register Lisp_Object variable
, Lisp_Object buffer
)
1826 register struct buffer
*buf
;
1827 struct Lisp_Symbol
*sym
;
1830 buf
= current_buffer
;
1833 CHECK_BUFFER (buffer
);
1834 buf
= XBUFFER (buffer
);
1837 CHECK_SYMBOL (variable
);
1838 sym
= XSYMBOL (variable
);
1841 switch (sym
->redirect
)
1843 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1844 case SYMBOL_PLAINVAL
: return Qnil
;
1845 case SYMBOL_LOCALIZED
:
1847 Lisp_Object tail
, elt
, tmp
;
1848 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1849 XSETBUFFER (tmp
, buf
);
1850 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1852 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1855 if (EQ (variable
, XCAR (elt
)))
1857 eassert (!blv
->frame_local
);
1858 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1862 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1865 case SYMBOL_FORWARDED
:
1867 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1868 if (BUFFER_OBJFWDP (valcontents
))
1870 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1871 int idx
= PER_BUFFER_IDX (offset
);
1872 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1881 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1883 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1884 More precisely, this means that setting the variable \(with `set' or`setq'),
1885 while it does not have a `let'-style binding that was made in BUFFER,
1886 will produce a buffer local binding. See Info node
1887 `(elisp)Creating Buffer-Local'.
1888 BUFFER defaults to the current buffer. */)
1889 (register Lisp_Object variable
, Lisp_Object buffer
)
1891 struct Lisp_Symbol
*sym
;
1893 CHECK_SYMBOL (variable
);
1894 sym
= XSYMBOL (variable
);
1897 switch (sym
->redirect
)
1899 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1900 case SYMBOL_PLAINVAL
: return Qnil
;
1901 case SYMBOL_LOCALIZED
:
1903 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1904 if (blv
->local_if_set
)
1906 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1907 return Flocal_variable_p (variable
, buffer
);
1909 case SYMBOL_FORWARDED
:
1910 /* All BUFFER_OBJFWD slots become local if they are set. */
1911 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1916 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1918 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1919 If the current binding is buffer-local, the value is the current buffer.
1920 If the current binding is frame-local, the value is the selected frame.
1921 If the current binding is global (the default), the value is nil. */)
1922 (register Lisp_Object variable
)
1924 struct Lisp_Symbol
*sym
;
1926 CHECK_SYMBOL (variable
);
1927 sym
= XSYMBOL (variable
);
1929 /* Make sure the current binding is actually swapped in. */
1930 find_symbol_value (variable
);
1933 switch (sym
->redirect
)
1935 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1936 case SYMBOL_PLAINVAL
: return Qnil
;
1937 case SYMBOL_FORWARDED
:
1939 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1940 if (KBOARD_OBJFWDP (valcontents
))
1941 return Fframe_terminal (Fselected_frame ());
1942 else if (!BUFFER_OBJFWDP (valcontents
))
1946 case SYMBOL_LOCALIZED
:
1947 /* For a local variable, record both the symbol and which
1948 buffer's or frame's value we are saving. */
1949 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1950 return Fcurrent_buffer ();
1951 else if (sym
->redirect
== SYMBOL_LOCALIZED
1952 && BLV_FOUND (SYMBOL_BLV (sym
)))
1953 return SYMBOL_BLV (sym
)->where
;
1960 /* This code is disabled now that we use the selected frame to return
1961 keyboard-local-values. */
1963 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1965 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1966 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1967 If SYMBOL is not a terminal-local variable, then return its normal
1968 value, like `symbol-value'.
1970 TERMINAL may be a terminal object, a frame, or nil (meaning the
1971 selected frame's terminal device). */)
1972 (Lisp_Object symbol
, Lisp_Object terminal
)
1975 struct terminal
*t
= get_terminal (terminal
, 1);
1976 push_kboard (t
->kboard
);
1977 result
= Fsymbol_value (symbol
);
1982 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1983 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1984 If VARIABLE is not a terminal-local variable, then set its normal
1985 binding, like `set'.
1987 TERMINAL may be a terminal object, a frame, or nil (meaning the
1988 selected frame's terminal device). */)
1989 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1992 struct terminal
*t
= get_terminal (terminal
, 1);
1993 push_kboard (d
->kboard
);
1994 result
= Fset (symbol
, value
);
2000 /* Find the function at the end of a chain of symbol function indirections. */
2002 /* If OBJECT is a symbol, find the end of its function chain and
2003 return the value found there. If OBJECT is not a symbol, just
2004 return it. If there is a cycle in the function chain, signal a
2005 cyclic-function-indirection error.
2007 This is like Findirect_function, except that it doesn't signal an
2008 error if the chain ends up unbound. */
2010 indirect_function (register Lisp_Object object
)
2012 Lisp_Object tortoise
, hare
;
2014 hare
= tortoise
= object
;
2018 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2020 hare
= XSYMBOL (hare
)->function
;
2021 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2023 hare
= XSYMBOL (hare
)->function
;
2025 tortoise
= XSYMBOL (tortoise
)->function
;
2027 if (EQ (hare
, tortoise
))
2028 xsignal1 (Qcyclic_function_indirection
, object
);
2034 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2035 doc
: /* Return the function at the end of OBJECT's function chain.
2036 If OBJECT is not a symbol, just return it. Otherwise, follow all
2037 function indirections to find the final function binding and return it.
2038 If the final symbol in the chain is unbound, signal a void-function error.
2039 Optional arg NOERROR non-nil means to return nil instead of signalling.
2040 Signal a cyclic-function-indirection error if there is a loop in the
2041 function chain of symbols. */)
2042 (register Lisp_Object object
, Lisp_Object noerror
)
2046 /* Optimize for no indirection. */
2048 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2049 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2050 result
= indirect_function (result
);
2051 if (!EQ (result
, Qunbound
))
2055 xsignal1 (Qvoid_function
, object
);
2060 /* Extract and set vector and string elements */
2062 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2063 doc
: /* Return the element of ARRAY at index IDX.
2064 ARRAY may be a vector, a string, a char-table, a bool-vector,
2065 or a byte-code object. IDX starts at 0. */)
2066 (register Lisp_Object array
, Lisp_Object idx
)
2068 register EMACS_INT idxval
;
2071 idxval
= XINT (idx
);
2072 if (STRINGP (array
))
2075 EMACS_INT idxval_byte
;
2077 if (idxval
< 0 || idxval
>= SCHARS (array
))
2078 args_out_of_range (array
, idx
);
2079 if (! STRING_MULTIBYTE (array
))
2080 return make_number ((unsigned char) SREF (array
, idxval
));
2081 idxval_byte
= string_char_to_byte (array
, idxval
);
2083 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2084 return make_number (c
);
2086 else if (BOOL_VECTOR_P (array
))
2090 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2091 args_out_of_range (array
, idx
);
2093 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2094 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2096 else if (CHAR_TABLE_P (array
))
2098 CHECK_CHARACTER (idx
);
2099 return CHAR_TABLE_REF (array
, idxval
);
2104 if (VECTORP (array
))
2105 size
= XVECTOR (array
)->size
;
2106 else if (COMPILEDP (array
))
2107 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2109 wrong_type_argument (Qarrayp
, array
);
2111 if (idxval
< 0 || idxval
>= size
)
2112 args_out_of_range (array
, idx
);
2113 return XVECTOR (array
)->contents
[idxval
];
2117 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2118 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2119 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2120 bool-vector. IDX starts at 0. */)
2121 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2123 register EMACS_INT idxval
;
2126 idxval
= XINT (idx
);
2127 CHECK_ARRAY (array
, Qarrayp
);
2128 CHECK_IMPURE (array
);
2130 if (VECTORP (array
))
2132 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2133 args_out_of_range (array
, idx
);
2134 XVECTOR (array
)->contents
[idxval
] = newelt
;
2136 else if (BOOL_VECTOR_P (array
))
2140 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2141 args_out_of_range (array
, idx
);
2143 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2145 if (! NILP (newelt
))
2146 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2148 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2149 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2151 else if (CHAR_TABLE_P (array
))
2153 CHECK_CHARACTER (idx
);
2154 CHAR_TABLE_SET (array
, idxval
, newelt
);
2156 else if (STRING_MULTIBYTE (array
))
2158 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2159 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2161 if (idxval
< 0 || idxval
>= SCHARS (array
))
2162 args_out_of_range (array
, idx
);
2163 CHECK_CHARACTER (newelt
);
2165 nbytes
= SBYTES (array
);
2167 idxval_byte
= string_char_to_byte (array
, idxval
);
2168 p1
= SDATA (array
) + idxval_byte
;
2169 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2170 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2171 if (prev_bytes
!= new_bytes
)
2173 /* We must relocate the string data. */
2174 EMACS_INT nchars
= SCHARS (array
);
2178 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2179 memcpy (str
, SDATA (array
), nbytes
);
2180 allocate_string_data (XSTRING (array
), nchars
,
2181 nbytes
+ new_bytes
- prev_bytes
);
2182 memcpy (SDATA (array
), str
, idxval_byte
);
2183 p1
= SDATA (array
) + idxval_byte
;
2184 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2185 nbytes
- (idxval_byte
+ prev_bytes
));
2187 clear_string_char_byte_cache ();
2194 if (idxval
< 0 || idxval
>= SCHARS (array
))
2195 args_out_of_range (array
, idx
);
2196 CHECK_NUMBER (newelt
);
2198 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2202 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2203 if (SREF (array
, i
) >= 0x80)
2204 args_out_of_range (array
, newelt
);
2205 /* ARRAY is an ASCII string. Convert it to a multibyte
2206 string, and try `aset' again. */
2207 STRING_SET_MULTIBYTE (array
);
2208 return Faset (array
, idx
, newelt
);
2210 SSET (array
, idxval
, XINT (newelt
));
2216 /* Arithmetic functions */
2218 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2221 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2223 double f1
= 0, f2
= 0;
2226 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2227 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2229 if (FLOATP (num1
) || FLOATP (num2
))
2232 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2233 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : 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
))
2264 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2273 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2274 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2275 (register Lisp_Object num1
, Lisp_Object num2
)
2277 return arithcompare (num1
, num2
, equal
);
2280 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2281 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2282 (register Lisp_Object num1
, Lisp_Object num2
)
2284 return arithcompare (num1
, num2
, less
);
2287 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2288 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2289 (register Lisp_Object num1
, Lisp_Object num2
)
2291 return arithcompare (num1
, num2
, grtr
);
2294 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2295 doc
: /* Return t if first arg is less than or equal to second arg.
2296 Both must be numbers or markers. */)
2297 (register Lisp_Object num1
, Lisp_Object num2
)
2299 return arithcompare (num1
, num2
, less_or_equal
);
2302 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2303 doc
: /* Return t if first arg is greater than or equal to second arg.
2304 Both must be numbers or markers. */)
2305 (register Lisp_Object num1
, Lisp_Object num2
)
2307 return arithcompare (num1
, num2
, grtr_or_equal
);
2310 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2311 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2312 (register Lisp_Object num1
, Lisp_Object num2
)
2314 return arithcompare (num1
, num2
, notequal
);
2317 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2318 doc
: /* Return t if NUMBER is zero. */)
2319 (register Lisp_Object number
)
2321 CHECK_NUMBER_OR_FLOAT (number
);
2323 if (FLOATP (number
))
2325 if (XFLOAT_DATA (number
) == 0.0)
2335 /* Convert between long values and pairs of Lisp integers.
2336 Note that long_to_cons returns a single Lisp integer
2337 when the value fits in one. */
2340 long_to_cons (long unsigned int i
)
2342 unsigned long top
= i
>> 16;
2343 unsigned int bot
= i
& 0xFFFF;
2345 return make_number (bot
);
2346 if (top
== (unsigned long)-1 >> 16)
2347 return Fcons (make_number (-1), make_number (bot
));
2348 return Fcons (make_number (top
), make_number (bot
));
2352 cons_to_long (Lisp_Object c
)
2354 Lisp_Object top
, bot
;
2361 return ((XINT (top
) << 16) | XINT (bot
));
2364 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2365 doc
: /* Return the decimal representation of NUMBER as a string.
2366 Uses a minus sign if negative.
2367 NUMBER may be an integer or a floating point number. */)
2368 (Lisp_Object number
)
2370 char buffer
[VALBITS
];
2372 CHECK_NUMBER_OR_FLOAT (number
);
2374 if (FLOATP (number
))
2376 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2378 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2379 return build_string (pigbuf
);
2382 if (sizeof (int) == sizeof (EMACS_INT
))
2383 sprintf (buffer
, "%d", (int) XINT (number
));
2384 else if (sizeof (long) == sizeof (EMACS_INT
))
2385 sprintf (buffer
, "%ld", (long) XINT (number
));
2388 return build_string (buffer
);
2392 digit_to_number (int character
, int base
)
2396 if (character
>= '0' && character
<= '9')
2397 digit
= character
- '0';
2398 else if (character
>= 'a' && character
<= 'z')
2399 digit
= character
- 'a' + 10;
2400 else if (character
>= 'A' && character
<= 'Z')
2401 digit
= character
- 'A' + 10;
2411 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2412 doc
: /* Parse STRING as a decimal number and return the number.
2413 This parses both integers and floating point numbers.
2414 It ignores leading spaces and tabs, and all trailing chars.
2416 If BASE, interpret STRING as a number in that base. If BASE isn't
2417 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2418 If the base used is not 10, STRING is always parsed as integer. */)
2419 (register Lisp_Object string
, Lisp_Object base
)
2421 register unsigned char *p
;
2426 CHECK_STRING (string
);
2432 CHECK_NUMBER (base
);
2434 if (b
< 2 || b
> 16)
2435 xsignal1 (Qargs_out_of_range
, base
);
2438 /* Skip any whitespace at the front of the number. Some versions of
2439 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2441 while (*p
== ' ' || *p
== '\t')
2452 if (isfloat_string (p
, 1) && b
== 10)
2453 val
= make_float (sign
* atof (p
));
2460 int digit
= digit_to_number (*p
++, b
);
2466 val
= make_fixnum_or_float (sign
* v
);
2486 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2487 int, Lisp_Object
*);
2489 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2491 register Lisp_Object val
;
2492 register int argnum
;
2493 register EMACS_INT accum
= 0;
2494 register EMACS_INT next
;
2496 switch (SWITCH_ENUM_CAST (code
))
2514 for (argnum
= 0; argnum
< nargs
; argnum
++)
2516 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2518 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2521 return float_arith_driver ((double) accum
, argnum
, code
,
2524 next
= XINT (args
[argnum
]);
2525 switch (SWITCH_ENUM_CAST (code
))
2531 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2542 xsignal0 (Qarith_error
);
2556 if (!argnum
|| next
> accum
)
2560 if (!argnum
|| next
< accum
)
2566 XSETINT (val
, accum
);
2571 #define isnan(x) ((x) != (x))
2574 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2576 register Lisp_Object val
;
2579 for (; argnum
< nargs
; argnum
++)
2581 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2582 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2586 next
= XFLOAT_DATA (val
);
2590 args
[argnum
] = val
; /* runs into a compiler bug. */
2591 next
= XINT (args
[argnum
]);
2593 switch (SWITCH_ENUM_CAST (code
))
2599 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2609 if (! IEEE_FLOATING_POINT
&& next
== 0)
2610 xsignal0 (Qarith_error
);
2617 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2619 if (!argnum
|| isnan (next
) || next
> accum
)
2623 if (!argnum
|| isnan (next
) || next
< accum
)
2629 return make_float (accum
);
2633 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2634 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2635 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2636 (int nargs
, Lisp_Object
*args
)
2638 return arith_driver (Aadd
, nargs
, args
);
2641 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2642 doc
: /* Negate number or subtract numbers or markers and return the result.
2643 With one arg, negates it. With more than one arg,
2644 subtracts all but the first from the first.
2645 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2646 (int nargs
, Lisp_Object
*args
)
2648 return arith_driver (Asub
, nargs
, args
);
2651 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2652 doc
: /* Return product of any number of arguments, which are numbers or markers.
2653 usage: (* &rest NUMBERS-OR-MARKERS) */)
2654 (int nargs
, Lisp_Object
*args
)
2656 return arith_driver (Amult
, nargs
, args
);
2659 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2660 doc
: /* Return first argument divided by all the remaining arguments.
2661 The arguments must be numbers or markers.
2662 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2663 (int nargs
, Lisp_Object
*args
)
2666 for (argnum
= 2; argnum
< nargs
; argnum
++)
2667 if (FLOATP (args
[argnum
]))
2668 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2669 return arith_driver (Adiv
, nargs
, args
);
2672 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2673 doc
: /* Return remainder of X divided by Y.
2674 Both must be integers or markers. */)
2675 (register Lisp_Object x
, Lisp_Object y
)
2679 CHECK_NUMBER_COERCE_MARKER (x
);
2680 CHECK_NUMBER_COERCE_MARKER (y
);
2682 if (XFASTINT (y
) == 0)
2683 xsignal0 (Qarith_error
);
2685 XSETINT (val
, XINT (x
) % XINT (y
));
2699 /* If the magnitude of the result exceeds that of the divisor, or
2700 the sign of the result does not agree with that of the dividend,
2701 iterate with the reduced value. This does not yield a
2702 particularly accurate result, but at least it will be in the
2703 range promised by fmod. */
2705 r
-= f2
* floor (r
/ f2
);
2706 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2710 #endif /* ! HAVE_FMOD */
2712 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2713 doc
: /* Return X modulo Y.
2714 The result falls between zero (inclusive) and Y (exclusive).
2715 Both X and Y must be numbers or markers. */)
2716 (register Lisp_Object x
, Lisp_Object y
)
2721 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2722 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2724 if (FLOATP (x
) || FLOATP (y
))
2725 return fmod_float (x
, y
);
2731 xsignal0 (Qarith_error
);
2735 /* If the "remainder" comes out with the wrong sign, fix it. */
2736 if (i2
< 0 ? i1
> 0 : i1
< 0)
2743 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2744 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2745 The value is always a number; markers are converted to numbers.
2746 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2747 (int nargs
, Lisp_Object
*args
)
2749 return arith_driver (Amax
, nargs
, args
);
2752 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2753 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2754 The value is always a number; markers are converted to numbers.
2755 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2756 (int nargs
, Lisp_Object
*args
)
2758 return arith_driver (Amin
, nargs
, args
);
2761 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2762 doc
: /* Return bitwise-and of all the arguments.
2763 Arguments may be integers, or markers converted to integers.
2764 usage: (logand &rest INTS-OR-MARKERS) */)
2765 (int nargs
, Lisp_Object
*args
)
2767 return arith_driver (Alogand
, nargs
, args
);
2770 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2771 doc
: /* Return bitwise-or of all the arguments.
2772 Arguments may be integers, or markers converted to integers.
2773 usage: (logior &rest INTS-OR-MARKERS) */)
2774 (int nargs
, Lisp_Object
*args
)
2776 return arith_driver (Alogior
, nargs
, args
);
2779 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2780 doc
: /* Return bitwise-exclusive-or of all the arguments.
2781 Arguments may be integers, or markers converted to integers.
2782 usage: (logxor &rest INTS-OR-MARKERS) */)
2783 (int nargs
, Lisp_Object
*args
)
2785 return arith_driver (Alogxor
, nargs
, args
);
2788 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2789 doc
: /* Return VALUE with its bits shifted left by COUNT.
2790 If COUNT is negative, shifting is actually to the right.
2791 In this case, the sign bit is duplicated. */)
2792 (register Lisp_Object value
, Lisp_Object count
)
2794 register Lisp_Object val
;
2796 CHECK_NUMBER (value
);
2797 CHECK_NUMBER (count
);
2799 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2801 else if (XINT (count
) > 0)
2802 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2803 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2804 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2806 XSETINT (val
, XINT (value
) >> -XINT (count
));
2810 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2811 doc
: /* Return VALUE with its bits shifted left by COUNT.
2812 If COUNT is negative, shifting is actually to the right.
2813 In this case, zeros are shifted in on the left. */)
2814 (register Lisp_Object value
, Lisp_Object count
)
2816 register Lisp_Object val
;
2818 CHECK_NUMBER (value
);
2819 CHECK_NUMBER (count
);
2821 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2823 else if (XINT (count
) > 0)
2824 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2825 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2828 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2832 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2833 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2834 Markers are converted to integers. */)
2835 (register Lisp_Object number
)
2837 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2839 if (FLOATP (number
))
2840 return (make_float (1.0 + XFLOAT_DATA (number
)));
2842 XSETINT (number
, XINT (number
) + 1);
2846 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2847 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2848 Markers are converted to integers. */)
2849 (register Lisp_Object number
)
2851 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2853 if (FLOATP (number
))
2854 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2856 XSETINT (number
, XINT (number
) - 1);
2860 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2861 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2862 (register Lisp_Object number
)
2864 CHECK_NUMBER (number
);
2865 XSETINT (number
, ~XINT (number
));
2869 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2870 doc
: /* Return the byteorder for the machine.
2871 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2872 lowercase l) for small endian machines. */)
2875 unsigned i
= 0x04030201;
2876 int order
= *(char *)&i
== 1 ? 108 : 66;
2878 return make_number (order
);
2886 Lisp_Object error_tail
, arith_tail
;
2888 Qquote
= intern_c_string ("quote");
2889 Qlambda
= intern_c_string ("lambda");
2890 Qsubr
= intern_c_string ("subr");
2891 Qerror_conditions
= intern_c_string ("error-conditions");
2892 Qerror_message
= intern_c_string ("error-message");
2893 Qtop_level
= intern_c_string ("top-level");
2895 Qerror
= intern_c_string ("error");
2896 Qquit
= intern_c_string ("quit");
2897 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2898 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2899 Qvoid_function
= intern_c_string ("void-function");
2900 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2901 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2902 Qvoid_variable
= intern_c_string ("void-variable");
2903 Qsetting_constant
= intern_c_string ("setting-constant");
2904 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2906 Qinvalid_function
= intern_c_string ("invalid-function");
2907 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2908 Qno_catch
= intern_c_string ("no-catch");
2909 Qend_of_file
= intern_c_string ("end-of-file");
2910 Qarith_error
= intern_c_string ("arith-error");
2911 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2912 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2913 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2914 Qtext_read_only
= intern_c_string ("text-read-only");
2915 Qmark_inactive
= intern_c_string ("mark-inactive");
2917 Qlistp
= intern_c_string ("listp");
2918 Qconsp
= intern_c_string ("consp");
2919 Qsymbolp
= intern_c_string ("symbolp");
2920 Qkeywordp
= intern_c_string ("keywordp");
2921 Qintegerp
= intern_c_string ("integerp");
2922 Qnatnump
= intern_c_string ("natnump");
2923 Qwholenump
= intern_c_string ("wholenump");
2924 Qstringp
= intern_c_string ("stringp");
2925 Qarrayp
= intern_c_string ("arrayp");
2926 Qsequencep
= intern_c_string ("sequencep");
2927 Qbufferp
= intern_c_string ("bufferp");
2928 Qvectorp
= intern_c_string ("vectorp");
2929 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2930 Qmarkerp
= intern_c_string ("markerp");
2931 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2932 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2933 Qboundp
= intern_c_string ("boundp");
2934 Qfboundp
= intern_c_string ("fboundp");
2936 Qfloatp
= intern_c_string ("floatp");
2937 Qnumberp
= intern_c_string ("numberp");
2938 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2940 Qchar_table_p
= intern_c_string ("char-table-p");
2941 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2943 Qsubrp
= intern_c_string ("subrp");
2944 Qunevalled
= intern_c_string ("unevalled");
2945 Qmany
= intern_c_string ("many");
2947 Qcdr
= intern_c_string ("cdr");
2949 /* Handle automatic advice activation */
2950 Qad_advice_info
= intern_c_string ("ad-advice-info");
2951 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2953 error_tail
= pure_cons (Qerror
, Qnil
);
2955 /* ERROR is used as a signaler for random errors for which nothing else is right */
2957 Fput (Qerror
, Qerror_conditions
,
2959 Fput (Qerror
, Qerror_message
,
2960 make_pure_c_string ("error"));
2962 Fput (Qquit
, Qerror_conditions
,
2963 pure_cons (Qquit
, Qnil
));
2964 Fput (Qquit
, Qerror_message
,
2965 make_pure_c_string ("Quit"));
2967 Fput (Qwrong_type_argument
, Qerror_conditions
,
2968 pure_cons (Qwrong_type_argument
, error_tail
));
2969 Fput (Qwrong_type_argument
, Qerror_message
,
2970 make_pure_c_string ("Wrong type argument"));
2972 Fput (Qargs_out_of_range
, Qerror_conditions
,
2973 pure_cons (Qargs_out_of_range
, error_tail
));
2974 Fput (Qargs_out_of_range
, Qerror_message
,
2975 make_pure_c_string ("Args out of range"));
2977 Fput (Qvoid_function
, Qerror_conditions
,
2978 pure_cons (Qvoid_function
, error_tail
));
2979 Fput (Qvoid_function
, Qerror_message
,
2980 make_pure_c_string ("Symbol's function definition is void"));
2982 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2983 pure_cons (Qcyclic_function_indirection
, error_tail
));
2984 Fput (Qcyclic_function_indirection
, Qerror_message
,
2985 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2987 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2988 pure_cons (Qcyclic_variable_indirection
, error_tail
));
2989 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2990 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
2992 Qcircular_list
= intern_c_string ("circular-list");
2993 staticpro (&Qcircular_list
);
2994 Fput (Qcircular_list
, Qerror_conditions
,
2995 pure_cons (Qcircular_list
, error_tail
));
2996 Fput (Qcircular_list
, Qerror_message
,
2997 make_pure_c_string ("List contains a loop"));
2999 Fput (Qvoid_variable
, Qerror_conditions
,
3000 pure_cons (Qvoid_variable
, error_tail
));
3001 Fput (Qvoid_variable
, Qerror_message
,
3002 make_pure_c_string ("Symbol's value as variable is void"));
3004 Fput (Qsetting_constant
, Qerror_conditions
,
3005 pure_cons (Qsetting_constant
, error_tail
));
3006 Fput (Qsetting_constant
, Qerror_message
,
3007 make_pure_c_string ("Attempt to set a constant symbol"));
3009 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3010 pure_cons (Qinvalid_read_syntax
, error_tail
));
3011 Fput (Qinvalid_read_syntax
, Qerror_message
,
3012 make_pure_c_string ("Invalid read syntax"));
3014 Fput (Qinvalid_function
, Qerror_conditions
,
3015 pure_cons (Qinvalid_function
, error_tail
));
3016 Fput (Qinvalid_function
, Qerror_message
,
3017 make_pure_c_string ("Invalid function"));
3019 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3020 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3021 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3022 make_pure_c_string ("Wrong number of arguments"));
3024 Fput (Qno_catch
, Qerror_conditions
,
3025 pure_cons (Qno_catch
, error_tail
));
3026 Fput (Qno_catch
, Qerror_message
,
3027 make_pure_c_string ("No catch for tag"));
3029 Fput (Qend_of_file
, Qerror_conditions
,
3030 pure_cons (Qend_of_file
, error_tail
));
3031 Fput (Qend_of_file
, Qerror_message
,
3032 make_pure_c_string ("End of file during parsing"));
3034 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3035 Fput (Qarith_error
, Qerror_conditions
,
3037 Fput (Qarith_error
, Qerror_message
,
3038 make_pure_c_string ("Arithmetic error"));
3040 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3041 pure_cons (Qbeginning_of_buffer
, error_tail
));
3042 Fput (Qbeginning_of_buffer
, Qerror_message
,
3043 make_pure_c_string ("Beginning of buffer"));
3045 Fput (Qend_of_buffer
, Qerror_conditions
,
3046 pure_cons (Qend_of_buffer
, error_tail
));
3047 Fput (Qend_of_buffer
, Qerror_message
,
3048 make_pure_c_string ("End of buffer"));
3050 Fput (Qbuffer_read_only
, Qerror_conditions
,
3051 pure_cons (Qbuffer_read_only
, error_tail
));
3052 Fput (Qbuffer_read_only
, Qerror_message
,
3053 make_pure_c_string ("Buffer is read-only"));
3055 Fput (Qtext_read_only
, Qerror_conditions
,
3056 pure_cons (Qtext_read_only
, error_tail
));
3057 Fput (Qtext_read_only
, Qerror_message
,
3058 make_pure_c_string ("Text is read-only"));
3060 Qrange_error
= intern_c_string ("range-error");
3061 Qdomain_error
= intern_c_string ("domain-error");
3062 Qsingularity_error
= intern_c_string ("singularity-error");
3063 Qoverflow_error
= intern_c_string ("overflow-error");
3064 Qunderflow_error
= intern_c_string ("underflow-error");
3066 Fput (Qdomain_error
, Qerror_conditions
,
3067 pure_cons (Qdomain_error
, arith_tail
));
3068 Fput (Qdomain_error
, Qerror_message
,
3069 make_pure_c_string ("Arithmetic domain error"));
3071 Fput (Qrange_error
, Qerror_conditions
,
3072 pure_cons (Qrange_error
, arith_tail
));
3073 Fput (Qrange_error
, Qerror_message
,
3074 make_pure_c_string ("Arithmetic range error"));
3076 Fput (Qsingularity_error
, Qerror_conditions
,
3077 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3078 Fput (Qsingularity_error
, Qerror_message
,
3079 make_pure_c_string ("Arithmetic singularity error"));
3081 Fput (Qoverflow_error
, Qerror_conditions
,
3082 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3083 Fput (Qoverflow_error
, Qerror_message
,
3084 make_pure_c_string ("Arithmetic overflow error"));
3086 Fput (Qunderflow_error
, Qerror_conditions
,
3087 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3088 Fput (Qunderflow_error
, Qerror_message
,
3089 make_pure_c_string ("Arithmetic underflow error"));
3091 staticpro (&Qrange_error
);
3092 staticpro (&Qdomain_error
);
3093 staticpro (&Qsingularity_error
);
3094 staticpro (&Qoverflow_error
);
3095 staticpro (&Qunderflow_error
);
3099 staticpro (&Qquote
);
3100 staticpro (&Qlambda
);
3102 staticpro (&Qunbound
);
3103 staticpro (&Qerror_conditions
);
3104 staticpro (&Qerror_message
);
3105 staticpro (&Qtop_level
);
3107 staticpro (&Qerror
);
3109 staticpro (&Qwrong_type_argument
);
3110 staticpro (&Qargs_out_of_range
);
3111 staticpro (&Qvoid_function
);
3112 staticpro (&Qcyclic_function_indirection
);
3113 staticpro (&Qcyclic_variable_indirection
);
3114 staticpro (&Qvoid_variable
);
3115 staticpro (&Qsetting_constant
);
3116 staticpro (&Qinvalid_read_syntax
);
3117 staticpro (&Qwrong_number_of_arguments
);
3118 staticpro (&Qinvalid_function
);
3119 staticpro (&Qno_catch
);
3120 staticpro (&Qend_of_file
);
3121 staticpro (&Qarith_error
);
3122 staticpro (&Qbeginning_of_buffer
);
3123 staticpro (&Qend_of_buffer
);
3124 staticpro (&Qbuffer_read_only
);
3125 staticpro (&Qtext_read_only
);
3126 staticpro (&Qmark_inactive
);
3128 staticpro (&Qlistp
);
3129 staticpro (&Qconsp
);
3130 staticpro (&Qsymbolp
);
3131 staticpro (&Qkeywordp
);
3132 staticpro (&Qintegerp
);
3133 staticpro (&Qnatnump
);
3134 staticpro (&Qwholenump
);
3135 staticpro (&Qstringp
);
3136 staticpro (&Qarrayp
);
3137 staticpro (&Qsequencep
);
3138 staticpro (&Qbufferp
);
3139 staticpro (&Qvectorp
);
3140 staticpro (&Qchar_or_string_p
);
3141 staticpro (&Qmarkerp
);
3142 staticpro (&Qbuffer_or_string_p
);
3143 staticpro (&Qinteger_or_marker_p
);
3144 staticpro (&Qfloatp
);
3145 staticpro (&Qnumberp
);
3146 staticpro (&Qnumber_or_marker_p
);
3147 staticpro (&Qchar_table_p
);
3148 staticpro (&Qvector_or_char_table_p
);
3149 staticpro (&Qsubrp
);
3151 staticpro (&Qunevalled
);
3153 staticpro (&Qboundp
);
3154 staticpro (&Qfboundp
);
3156 staticpro (&Qad_advice_info
);
3157 staticpro (&Qad_activate_internal
);
3159 /* Types that type-of returns. */
3160 Qinteger
= intern_c_string ("integer");
3161 Qsymbol
= intern_c_string ("symbol");
3162 Qstring
= intern_c_string ("string");
3163 Qcons
= intern_c_string ("cons");
3164 Qmarker
= intern_c_string ("marker");
3165 Qoverlay
= intern_c_string ("overlay");
3166 Qfloat
= intern_c_string ("float");
3167 Qwindow_configuration
= intern_c_string ("window-configuration");
3168 Qprocess
= intern_c_string ("process");
3169 Qwindow
= intern_c_string ("window");
3170 /* Qsubr = intern_c_string ("subr"); */
3171 Qcompiled_function
= intern_c_string ("compiled-function");
3172 Qbuffer
= intern_c_string ("buffer");
3173 Qframe
= intern_c_string ("frame");
3174 Qvector
= intern_c_string ("vector");
3175 Qchar_table
= intern_c_string ("char-table");
3176 Qbool_vector
= intern_c_string ("bool-vector");
3177 Qhash_table
= intern_c_string ("hash-table");
3179 DEFSYM (Qfont_spec
, "font-spec");
3180 DEFSYM (Qfont_entity
, "font-entity");
3181 DEFSYM (Qfont_object
, "font-object");
3183 DEFSYM (Qinteractive_form
, "interactive-form");
3185 staticpro (&Qinteger
);
3186 staticpro (&Qsymbol
);
3187 staticpro (&Qstring
);
3189 staticpro (&Qmarker
);
3190 staticpro (&Qoverlay
);
3191 staticpro (&Qfloat
);
3192 staticpro (&Qwindow_configuration
);
3193 staticpro (&Qprocess
);
3194 staticpro (&Qwindow
);
3195 /* staticpro (&Qsubr); */
3196 staticpro (&Qcompiled_function
);
3197 staticpro (&Qbuffer
);
3198 staticpro (&Qframe
);
3199 staticpro (&Qvector
);
3200 staticpro (&Qchar_table
);
3201 staticpro (&Qbool_vector
);
3202 staticpro (&Qhash_table
);
3204 defsubr (&Sindirect_variable
);
3205 defsubr (&Sinteractive_form
);
3208 defsubr (&Stype_of
);
3213 defsubr (&Sintegerp
);
3214 defsubr (&Sinteger_or_marker_p
);
3215 defsubr (&Snumberp
);
3216 defsubr (&Snumber_or_marker_p
);
3218 defsubr (&Snatnump
);
3219 defsubr (&Ssymbolp
);
3220 defsubr (&Skeywordp
);
3221 defsubr (&Sstringp
);
3222 defsubr (&Smultibyte_string_p
);
3223 defsubr (&Svectorp
);
3224 defsubr (&Schar_table_p
);
3225 defsubr (&Svector_or_char_table_p
);
3226 defsubr (&Sbool_vector_p
);
3228 defsubr (&Ssequencep
);
3229 defsubr (&Sbufferp
);
3230 defsubr (&Smarkerp
);
3232 defsubr (&Sbyte_code_function_p
);
3233 defsubr (&Schar_or_string_p
);
3236 defsubr (&Scar_safe
);
3237 defsubr (&Scdr_safe
);
3240 defsubr (&Ssymbol_function
);
3241 defsubr (&Sindirect_function
);
3242 defsubr (&Ssymbol_plist
);
3243 defsubr (&Ssymbol_name
);
3244 defsubr (&Smakunbound
);
3245 defsubr (&Sfmakunbound
);
3247 defsubr (&Sfboundp
);
3249 defsubr (&Sdefalias
);
3250 defsubr (&Ssetplist
);
3251 defsubr (&Ssymbol_value
);
3253 defsubr (&Sdefault_boundp
);
3254 defsubr (&Sdefault_value
);
3255 defsubr (&Sset_default
);
3256 defsubr (&Ssetq_default
);
3257 defsubr (&Smake_variable_buffer_local
);
3258 defsubr (&Smake_local_variable
);
3259 defsubr (&Skill_local_variable
);
3260 defsubr (&Smake_variable_frame_local
);
3261 defsubr (&Slocal_variable_p
);
3262 defsubr (&Slocal_variable_if_set_p
);
3263 defsubr (&Svariable_binding_locus
);
3264 #if 0 /* XXX Remove this. --lorentey */
3265 defsubr (&Sterminal_local_value
);
3266 defsubr (&Sset_terminal_local_value
);
3270 defsubr (&Snumber_to_string
);
3271 defsubr (&Sstring_to_number
);
3272 defsubr (&Seqlsign
);
3295 defsubr (&Sbyteorder
);
3296 defsubr (&Ssubr_arity
);
3297 defsubr (&Ssubr_name
);
3299 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3301 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3302 doc
: /* The largest value that is representable in a Lisp integer. */);
3303 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3304 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3306 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3307 doc
: /* The smallest value that is representable in a Lisp integer. */);
3308 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3309 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3313 arith_error (int signo
)
3315 sigsetmask (SIGEMPTYMASK
);
3317 SIGNAL_THREAD_CHECK (signo
);
3318 xsignal0 (Qarith_error
);
3324 /* Don't do this if just dumping out.
3325 We don't want to call `signal' in this case
3326 so that we don't have trouble with dumping
3327 signal-delivering routines in an inconsistent state. */
3331 #endif /* CANNOT_DUMP */
3332 signal (SIGFPE
, arith_error
);
3335 signal (SIGEMT
, arith_error
);