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
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
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
, Qwindow
;
87 static Lisp_Object Qcompiled_function
, Qfunction_vector
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
96 Lisp_Object Vmost_positive_fixnum
, Vmost_negative_fixnum
;
100 circular_list_error (Lisp_Object list
)
102 xsignal (Qcircular_list
, list
);
107 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
109 /* If VALUE is not even a valid Lisp object, we'd want to abort here
110 where we can get a backtrace showing where it came from. We used
111 to try and do that by checking the tagbits, but nowadays all
112 tagbits are potentially valid. */
113 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
116 xsignal2 (Qwrong_type_argument
, predicate
, value
);
120 pure_write_error (void)
122 error ("Attempt to modify read-only object");
126 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
128 xsignal2 (Qargs_out_of_range
, a1
, a2
);
132 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
134 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
137 /* On some machines, XINT needs a temporary location.
138 Here it is, in case it is needed. */
140 int sign_extend_temp
;
142 /* On a few machines, XINT can only be done by calling this. */
145 sign_extend_lisp_int (EMACS_INT num
)
147 if (num
& (((EMACS_INT
) 1) << (VALBITS
- 1)))
148 return num
| (((EMACS_INT
) (-1)) << VALBITS
);
150 return num
& ((((EMACS_INT
) 1) << VALBITS
) - 1);
153 /* Data type predicates */
155 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
156 doc
: /* Return t if the two args are the same Lisp object. */)
157 (Lisp_Object obj1
, Lisp_Object obj2
)
164 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
165 doc
: /* Return t if OBJECT is nil. */)
173 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
174 doc
: /* Return a symbol representing the type of OBJECT.
175 The symbol returned names the object's basic type;
176 for example, (type-of 1) returns `integer'. */)
179 switch (XTYPE (object
))
194 switch (XMISCTYPE (object
))
196 case Lisp_Misc_Marker
:
198 case Lisp_Misc_Overlay
:
200 case Lisp_Misc_Float
:
205 case Lisp_Vectorlike
:
206 if (WINDOW_CONFIGURATIONP (object
))
207 return Qwindow_configuration
;
208 if (PROCESSP (object
))
210 if (WINDOWP (object
))
214 if (FUNVECP (object
))
215 if (FUNVEC_COMPILED_P (object
))
216 return Qcompiled_function
;
218 return Qfunction_vector
;
219 if (BUFFERP (object
))
221 if (CHAR_TABLE_P (object
))
223 if (BOOL_VECTOR_P (object
))
227 if (HASH_TABLE_P (object
))
229 if (FONT_SPEC_P (object
))
231 if (FONT_ENTITY_P (object
))
233 if (FONT_OBJECT_P (object
))
245 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
246 doc
: /* Return t if OBJECT is a cons cell. */)
254 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
255 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
263 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
264 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
265 Otherwise, return nil. */)
268 if (CONSP (object
) || NILP (object
))
273 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
274 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
277 if (CONSP (object
) || NILP (object
))
282 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
283 doc
: /* Return t if OBJECT is a symbol. */)
286 if (SYMBOLP (object
))
291 /* Define this in C to avoid unnecessarily consing up the symbol
293 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
294 doc
: /* Return t if OBJECT is a keyword.
295 This means that it is a symbol with a print name beginning with `:'
296 interned in the initial obarray. */)
300 && SREF (SYMBOL_NAME (object
), 0) == ':'
301 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
306 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
307 doc
: /* Return t if OBJECT is a vector. */)
310 if (VECTORP (object
))
315 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
316 doc
: /* Return t if OBJECT is a string. */)
319 if (STRINGP (object
))
324 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
326 doc
: /* Return t if OBJECT is a multibyte string. */)
329 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
334 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
335 doc
: /* Return t if OBJECT is a char-table. */)
338 if (CHAR_TABLE_P (object
))
343 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
344 Svector_or_char_table_p
, 1, 1, 0,
345 doc
: /* Return t if OBJECT is a char-table or vector. */)
348 if (VECTORP (object
) || CHAR_TABLE_P (object
))
353 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
354 doc
: /* Return t if OBJECT is a bool-vector. */)
357 if (BOOL_VECTOR_P (object
))
362 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
363 doc
: /* Return t if OBJECT is an array (string or vector). */)
371 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
372 doc
: /* Return t if OBJECT is a sequence (list or array). */)
373 (register Lisp_Object object
)
375 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
380 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
381 doc
: /* Return t if OBJECT is an editor buffer. */)
384 if (BUFFERP (object
))
389 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
390 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
393 if (MARKERP (object
))
398 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
399 doc
: /* Return t if OBJECT is a built-in function. */)
407 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
409 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
412 if (COMPILEDP (object
))
417 DEFUN ("funvecp", Ffunvecp
, Sfunvecp
, 1, 1, 0,
418 doc
: /* Return t if OBJECT is a `function vector' object. */)
422 return FUNVECP (object
) ? Qt
: Qnil
;
425 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
426 doc
: /* Return t if OBJECT is a character or a string. */)
427 (register Lisp_Object object
)
429 if (CHARACTERP (object
) || STRINGP (object
))
434 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
435 doc
: /* Return t if OBJECT is an integer. */)
438 if (INTEGERP (object
))
443 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
444 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
445 (register Lisp_Object object
)
447 if (MARKERP (object
) || INTEGERP (object
))
452 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
453 doc
: /* Return t if OBJECT is a nonnegative integer. */)
456 if (NATNUMP (object
))
461 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
462 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
465 if (NUMBERP (object
))
471 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
472 Snumber_or_marker_p
, 1, 1, 0,
473 doc
: /* Return t if OBJECT is a number or a marker. */)
476 if (NUMBERP (object
) || MARKERP (object
))
481 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
482 doc
: /* Return t if OBJECT is a floating point number. */)
491 /* Extract and set components of lists */
493 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
494 doc
: /* Return the car of LIST. If arg is nil, return nil.
495 Error if arg is not nil and not a cons cell. See also `car-safe'.
497 See Info node `(elisp)Cons Cells' for a discussion of related basic
498 Lisp concepts such as car, cdr, cons cell and list. */)
499 (register Lisp_Object list
)
504 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
505 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
508 return CAR_SAFE (object
);
511 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
512 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
513 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
515 See Info node `(elisp)Cons Cells' for a discussion of related basic
516 Lisp concepts such as cdr, car, cons cell and list. */)
517 (register Lisp_Object list
)
522 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
523 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
526 return CDR_SAFE (object
);
529 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
530 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
531 (register Lisp_Object cell
, Lisp_Object newcar
)
535 XSETCAR (cell
, newcar
);
539 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
540 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
541 (register Lisp_Object cell
, Lisp_Object newcdr
)
545 XSETCDR (cell
, newcdr
);
549 /* Extract and set components of symbols */
551 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
552 doc
: /* Return t if SYMBOL's value is not void. */)
553 (register Lisp_Object symbol
)
555 Lisp_Object valcontents
;
556 struct Lisp_Symbol
*sym
;
557 CHECK_SYMBOL (symbol
);
558 sym
= XSYMBOL (symbol
);
561 switch (sym
->redirect
)
563 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
564 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
565 case SYMBOL_LOCALIZED
:
567 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
569 /* In set_internal, we un-forward vars when their value is
574 swap_in_symval_forwarding (sym
, blv
);
575 valcontents
= BLV_VALUE (blv
);
579 case SYMBOL_FORWARDED
:
580 /* In set_internal, we un-forward vars when their value is
586 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
589 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
590 doc
: /* Return t if SYMBOL's function definition is not void. */)
591 (register Lisp_Object symbol
)
593 CHECK_SYMBOL (symbol
);
594 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
597 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
598 doc
: /* Make SYMBOL's value be void.
600 (register Lisp_Object symbol
)
602 CHECK_SYMBOL (symbol
);
603 if (SYMBOL_CONSTANT_P (symbol
))
604 xsignal1 (Qsetting_constant
, symbol
);
605 Fset (symbol
, Qunbound
);
609 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
610 doc
: /* Make SYMBOL's function definition be void.
612 (register Lisp_Object symbol
)
614 CHECK_SYMBOL (symbol
);
615 if (NILP (symbol
) || EQ (symbol
, Qt
))
616 xsignal1 (Qsetting_constant
, symbol
);
617 XSYMBOL (symbol
)->function
= Qunbound
;
621 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
622 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
623 (register Lisp_Object symbol
)
625 CHECK_SYMBOL (symbol
);
626 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
627 return XSYMBOL (symbol
)->function
;
628 xsignal1 (Qvoid_function
, symbol
);
631 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
632 doc
: /* Return SYMBOL's property list. */)
633 (register Lisp_Object symbol
)
635 CHECK_SYMBOL (symbol
);
636 return XSYMBOL (symbol
)->plist
;
639 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
640 doc
: /* Return SYMBOL's name, a string. */)
641 (register Lisp_Object symbol
)
643 register Lisp_Object name
;
645 CHECK_SYMBOL (symbol
);
646 name
= SYMBOL_NAME (symbol
);
650 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
651 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
652 (register Lisp_Object symbol
, Lisp_Object definition
)
654 register Lisp_Object function
;
656 CHECK_SYMBOL (symbol
);
657 if (NILP (symbol
) || EQ (symbol
, Qt
))
658 xsignal1 (Qsetting_constant
, symbol
);
660 function
= XSYMBOL (symbol
)->function
;
662 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
663 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
665 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
666 Fput (symbol
, Qautoload
, XCDR (function
));
668 XSYMBOL (symbol
)->function
= definition
;
669 /* Handle automatic advice activation */
670 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
672 call2 (Qad_activate_internal
, symbol
, Qnil
);
673 definition
= XSYMBOL (symbol
)->function
;
678 extern Lisp_Object Qfunction_documentation
;
680 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
681 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
682 Associates the function with the current load file, if any.
683 The optional third argument DOCSTRING specifies the documentation string
684 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
685 determined by DEFINITION. */)
686 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
688 CHECK_SYMBOL (symbol
);
689 if (CONSP (XSYMBOL (symbol
)->function
)
690 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
691 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
692 definition
= Ffset (symbol
, definition
);
693 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
694 if (!NILP (docstring
))
695 Fput (symbol
, Qfunction_documentation
, docstring
);
699 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
700 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
701 (register Lisp_Object symbol
, Lisp_Object newplist
)
703 CHECK_SYMBOL (symbol
);
704 XSYMBOL (symbol
)->plist
= newplist
;
708 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
709 doc
: /* Return minimum and maximum number of args allowed for SUBR.
710 SUBR must be a built-in function.
711 The returned value is a pair (MIN . MAX). MIN is the minimum number
712 of args. MAX is the maximum number or the symbol `many', for a
713 function with `&rest' args, or `unevalled' for a special form. */)
716 short minargs
, maxargs
;
718 minargs
= XSUBR (subr
)->min_args
;
719 maxargs
= XSUBR (subr
)->max_args
;
721 return Fcons (make_number (minargs
), Qmany
);
722 else if (maxargs
== UNEVALLED
)
723 return Fcons (make_number (minargs
), Qunevalled
);
725 return Fcons (make_number (minargs
), make_number (maxargs
));
728 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
729 doc
: /* Return name of subroutine SUBR.
730 SUBR must be a built-in function. */)
735 name
= XSUBR (subr
)->symbol_name
;
736 return make_string (name
, strlen (name
));
739 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
740 doc
: /* Return the interactive form of CMD or nil if none.
741 If CMD is not a command, the return value is nil.
742 Value, if non-nil, is a list \(interactive SPEC). */)
745 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
747 if (NILP (fun
) || EQ (fun
, Qunbound
))
750 /* Use an `interactive-form' property if present, analogous to the
751 function-documentation property. */
753 while (SYMBOLP (fun
))
755 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
759 fun
= Fsymbol_function (fun
);
764 char *spec
= XSUBR (fun
)->intspec
;
766 return list2 (Qinteractive
,
767 (*spec
!= '(') ? build_string (spec
) :
768 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
770 else if (COMPILEDP (fun
))
772 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
773 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
775 else if (CONSP (fun
))
777 Lisp_Object funcar
= XCAR (fun
);
778 if (EQ (funcar
, Qlambda
))
779 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
780 else if (EQ (funcar
, Qautoload
))
784 do_autoload (fun
, cmd
);
786 return Finteractive_form (cmd
);
793 /***********************************************************************
794 Getting and Setting Values of Symbols
795 ***********************************************************************/
797 /* Return the symbol holding SYMBOL's value. Signal
798 `cyclic-variable-indirection' if SYMBOL's chain of variable
799 indirections contains a loop. */
802 indirect_variable (struct Lisp_Symbol
*symbol
)
804 struct Lisp_Symbol
*tortoise
, *hare
;
806 hare
= tortoise
= symbol
;
808 while (hare
->redirect
== SYMBOL_VARALIAS
)
810 hare
= SYMBOL_ALIAS (hare
);
811 if (hare
->redirect
!= SYMBOL_VARALIAS
)
814 hare
= SYMBOL_ALIAS (hare
);
815 tortoise
= SYMBOL_ALIAS (tortoise
);
817 if (hare
== tortoise
)
820 XSETSYMBOL (tem
, symbol
);
821 xsignal1 (Qcyclic_variable_indirection
, tem
);
829 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
830 doc
: /* Return the variable at the end of OBJECT's variable chain.
831 If OBJECT is a symbol, follow all variable indirections and return the final
832 variable. If OBJECT is not a symbol, just return it.
833 Signal a cyclic-variable-indirection error if there is a loop in the
834 variable chain of symbols. */)
837 if (SYMBOLP (object
))
838 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
843 /* Given the raw contents of a symbol value cell,
844 return the Lisp value of the symbol.
845 This does not handle buffer-local variables; use
846 swap_in_symval_forwarding for that. */
848 #define do_blv_forwarding(blv) \
849 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
852 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
854 register Lisp_Object val
;
855 switch (XFWDTYPE (valcontents
))
858 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
862 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
865 return *XOBJFWD (valcontents
)->objvar
;
867 case Lisp_Fwd_Buffer_Obj
:
868 return PER_BUFFER_VALUE (current_buffer
,
869 XBUFFER_OBJFWD (valcontents
)->offset
);
871 case Lisp_Fwd_Kboard_Obj
:
872 /* We used to simply use current_kboard here, but from Lisp
873 code, it's value is often unexpected. It seems nicer to
874 allow constructions like this to work as intuitively expected:
876 (with-selected-frame frame
877 (define-key local-function-map "\eOP" [f1]))
879 On the other hand, this affects the semantics of
880 last-command and real-last-command, and people may rely on
881 that. I took a quick look at the Lisp codebase, and I
882 don't think anything will break. --lorentey */
883 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
884 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
889 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
890 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
891 buffer-independent contents of the value cell: forwarded just one
892 step past the buffer-localness.
894 BUF non-zero means set the value in buffer BUF instead of the
895 current buffer. This only plays a role for per-buffer variables. */
897 #define store_blv_forwarding(blv, newval, buf) \
899 if ((blv)->forwarded) \
900 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
902 SET_BLV_VALUE (blv, newval); \
906 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
908 switch (XFWDTYPE (valcontents
))
911 CHECK_NUMBER (newval
);
912 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
916 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
920 *XOBJFWD (valcontents
)->objvar
= newval
;
922 /* If this variable is a default for something stored
923 in the buffer itself, such as default-fill-column,
924 find the buffers that don't have local values for it
926 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
927 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
929 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
930 - (char *) &buffer_defaults
);
931 int idx
= PER_BUFFER_IDX (offset
);
938 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
943 buf
= Fcdr (XCAR (tail
));
944 if (!BUFFERP (buf
)) continue;
947 if (! PER_BUFFER_VALUE_P (b
, idx
))
948 PER_BUFFER_VALUE (b
, offset
) = newval
;
953 case Lisp_Fwd_Buffer_Obj
:
955 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
956 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
958 if (!(NILP (type
) || NILP (newval
)
959 || (XINT (type
) == LISP_INT_TAG
961 : XTYPE (newval
) == XINT (type
))))
962 buffer_slot_type_mismatch (newval
, XINT (type
));
965 buf
= current_buffer
;
966 PER_BUFFER_VALUE (buf
, offset
) = newval
;
970 case Lisp_Fwd_Kboard_Obj
:
972 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
973 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
974 *(Lisp_Object
*) p
= newval
;
979 abort (); /* goto def; */
983 /* Set up SYMBOL to refer to its global binding.
984 This makes it safe to alter the status of other bindings. */
987 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
989 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
991 /* Unload the previously loaded binding. */
993 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
995 /* Select the global binding in the symbol. */
996 blv
->valcell
= blv
->defcell
;
998 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
1000 /* Indicate that the global binding is set up now. */
1002 SET_BLV_FOUND (blv
, 0);
1005 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1006 VALCONTENTS is the contents of its value cell,
1007 which points to a struct Lisp_Buffer_Local_Value.
1009 Return the value forwarded one step past the buffer-local stage.
1010 This could be another forwarding pointer. */
1013 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
1015 register Lisp_Object tem1
;
1017 eassert (blv
== SYMBOL_BLV (symbol
));
1022 || (blv
->frame_local
1023 ? !EQ (selected_frame
, tem1
)
1024 : current_buffer
!= XBUFFER (tem1
)))
1027 /* Unload the previously loaded binding. */
1028 tem1
= blv
->valcell
;
1030 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1031 /* Choose the new binding. */
1034 XSETSYMBOL (var
, symbol
);
1035 if (blv
->frame_local
)
1037 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1038 blv
->where
= selected_frame
;
1042 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1043 XSETBUFFER (blv
->where
, current_buffer
);
1046 if (!(blv
->found
= !NILP (tem1
)))
1047 tem1
= blv
->defcell
;
1049 /* Load the new binding. */
1050 blv
->valcell
= tem1
;
1052 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1056 /* Find the value of a symbol, returning Qunbound if it's not bound.
1057 This is helpful for code which just wants to get a variable's value
1058 if it has one, without signaling an error.
1059 Note that it must not be possible to quit
1060 within this function. Great care is required for this. */
1063 find_symbol_value (Lisp_Object symbol
)
1065 struct Lisp_Symbol
*sym
;
1067 CHECK_SYMBOL (symbol
);
1068 sym
= XSYMBOL (symbol
);
1071 switch (sym
->redirect
)
1073 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1074 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1075 case SYMBOL_LOCALIZED
:
1077 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1078 swap_in_symval_forwarding (sym
, blv
);
1079 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1082 case SYMBOL_FORWARDED
:
1083 return do_symval_forwarding (SYMBOL_FWD (sym
));
1088 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1089 doc
: /* Return SYMBOL's value. Error if that is void. */)
1090 (Lisp_Object symbol
)
1094 val
= find_symbol_value (symbol
);
1095 if (!EQ (val
, Qunbound
))
1098 xsignal1 (Qvoid_variable
, symbol
);
1101 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1102 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1103 (register Lisp_Object symbol
, Lisp_Object newval
)
1105 set_internal (symbol
, newval
, Qnil
, 0);
1109 /* Return 1 if SYMBOL currently has a let-binding
1110 which was made in the buffer that is now current. */
1113 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1115 struct specbinding
*p
;
1117 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1119 && CONSP (p
->symbol
))
1121 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1122 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1123 if (symbol
== let_bound_symbol
1124 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1128 return p
>= specpdl
;
1132 let_shadows_global_binding_p (Lisp_Object symbol
)
1134 struct specbinding
*p
;
1136 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1137 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1140 return p
>= specpdl
;
1143 /* Store the value NEWVAL into SYMBOL.
1144 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1145 (nil stands for the current buffer/frame).
1147 If BINDFLAG is zero, then if this symbol is supposed to become
1148 local in every buffer where it is set, then we make it local.
1149 If BINDFLAG is nonzero, we don't do that. */
1152 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1154 int voide
= EQ (newval
, Qunbound
);
1155 struct Lisp_Symbol
*sym
;
1158 /* If restoring in a dead buffer, do nothing. */
1159 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1162 CHECK_SYMBOL (symbol
);
1163 if (SYMBOL_CONSTANT_P (symbol
))
1165 if (NILP (Fkeywordp (symbol
))
1166 || !EQ (newval
, Fsymbol_value (symbol
)))
1167 xsignal1 (Qsetting_constant
, symbol
);
1169 /* Allow setting keywords to their own value. */
1173 sym
= XSYMBOL (symbol
);
1176 switch (sym
->redirect
)
1178 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1179 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1180 case SYMBOL_LOCALIZED
:
1182 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1185 if (blv
->frame_local
)
1186 where
= selected_frame
;
1188 XSETBUFFER (where
, current_buffer
);
1190 /* If the current buffer is not the buffer whose binding is
1191 loaded, or if there may be frame-local bindings and the frame
1192 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1193 the default binding is loaded, the loaded binding may be the
1195 if (!EQ (blv
->where
, where
)
1196 /* Also unload a global binding (if the var is local_if_set). */
1197 || (EQ (blv
->valcell
, blv
->defcell
)))
1199 /* The currently loaded binding is not necessarily valid.
1200 We need to unload it, and choose a new binding. */
1202 /* Write out `realvalue' to the old loaded binding. */
1204 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1206 /* Find the new binding. */
1207 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1208 tem1
= Fassq (symbol
,
1210 ? XFRAME (where
)->param_alist
1211 : XBUFFER (where
)->local_var_alist
));
1217 /* This buffer still sees the default value. */
1219 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1220 or if this is `let' rather than `set',
1221 make CURRENT-ALIST-ELEMENT point to itself,
1222 indicating that we're seeing the default value.
1223 Likewise if the variable has been let-bound
1224 in the current buffer. */
1225 if (bindflag
|| !blv
->local_if_set
1226 || let_shadows_buffer_binding_p (sym
))
1229 tem1
= blv
->defcell
;
1231 /* If it's a local_if_set, being set not bound,
1232 and we're not within a let that was made for this buffer,
1233 create a new buffer-local binding for the variable.
1234 That means, give this buffer a new assoc for a local value
1235 and load that binding. */
1238 /* local_if_set is only supported for buffer-local
1239 bindings, not for frame-local bindings. */
1240 eassert (!blv
->frame_local
);
1241 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1242 XBUFFER (where
)->local_var_alist
1243 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1247 /* Record which binding is now loaded. */
1248 blv
->valcell
= tem1
;
1251 /* Store the new value in the cons cell. */
1252 SET_BLV_VALUE (blv
, newval
);
1257 /* If storing void (making the symbol void), forward only through
1258 buffer-local indicator, not through Lisp_Objfwd, etc. */
1261 store_symval_forwarding (blv
->fwd
, newval
,
1263 ? XBUFFER (where
) : current_buffer
);
1267 case SYMBOL_FORWARDED
:
1270 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1271 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1272 if (BUFFER_OBJFWDP (innercontents
))
1274 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1275 int idx
= PER_BUFFER_IDX (offset
);
1278 && !let_shadows_buffer_binding_p (sym
))
1279 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1283 { /* If storing void (making the symbol void), forward only through
1284 buffer-local indicator, not through Lisp_Objfwd, etc. */
1285 sym
->redirect
= SYMBOL_PLAINVAL
;
1286 SET_SYMBOL_VAL (sym
, newval
);
1289 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1297 /* Access or set a buffer-local symbol's default value. */
1299 /* Return the default value of SYMBOL, but don't check for voidness.
1300 Return Qunbound if it is void. */
1303 default_value (Lisp_Object symbol
)
1305 struct Lisp_Symbol
*sym
;
1307 CHECK_SYMBOL (symbol
);
1308 sym
= XSYMBOL (symbol
);
1311 switch (sym
->redirect
)
1313 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1314 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1315 case SYMBOL_LOCALIZED
:
1317 /* If var is set up for a buffer that lacks a local value for it,
1318 the current value is nominally the default value.
1319 But the `realvalue' slot may be more up to date, since
1320 ordinary setq stores just that slot. So use that. */
1321 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1322 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1323 return do_symval_forwarding (blv
->fwd
);
1325 return XCDR (blv
->defcell
);
1327 case SYMBOL_FORWARDED
:
1329 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1331 /* For a built-in buffer-local variable, get the default value
1332 rather than letting do_symval_forwarding get the current value. */
1333 if (BUFFER_OBJFWDP (valcontents
))
1335 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1336 if (PER_BUFFER_IDX (offset
) != 0)
1337 return PER_BUFFER_DEFAULT (offset
);
1340 /* For other variables, get the current value. */
1341 return do_symval_forwarding (valcontents
);
1347 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1348 doc
: /* Return t if SYMBOL has a non-void default value.
1349 This is the value that is seen in buffers that do not have their own values
1350 for this variable. */)
1351 (Lisp_Object symbol
)
1353 register Lisp_Object value
;
1355 value
= default_value (symbol
);
1356 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1359 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1360 doc
: /* Return SYMBOL's default value.
1361 This is the value that is seen in buffers that do not have their own values
1362 for this variable. The default value is meaningful for variables with
1363 local bindings in certain buffers. */)
1364 (Lisp_Object symbol
)
1366 register Lisp_Object value
;
1368 value
= default_value (symbol
);
1369 if (!EQ (value
, Qunbound
))
1372 xsignal1 (Qvoid_variable
, symbol
);
1375 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1376 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1377 The default value is seen in buffers that do not have their own values
1378 for this variable. */)
1379 (Lisp_Object symbol
, Lisp_Object value
)
1381 struct Lisp_Symbol
*sym
;
1383 CHECK_SYMBOL (symbol
);
1384 if (SYMBOL_CONSTANT_P (symbol
))
1386 if (NILP (Fkeywordp (symbol
))
1387 || !EQ (value
, Fdefault_value (symbol
)))
1388 xsignal1 (Qsetting_constant
, symbol
);
1390 /* Allow setting keywords to their own value. */
1393 sym
= XSYMBOL (symbol
);
1396 switch (sym
->redirect
)
1398 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1399 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1400 case SYMBOL_LOCALIZED
:
1402 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1404 /* Store new value into the DEFAULT-VALUE slot. */
1405 XSETCDR (blv
->defcell
, value
);
1407 /* If the default binding is now loaded, set the REALVALUE slot too. */
1408 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1409 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1412 case SYMBOL_FORWARDED
:
1414 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1416 /* Handle variables like case-fold-search that have special slots
1418 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1419 if (BUFFER_OBJFWDP (valcontents
))
1421 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1422 int idx
= PER_BUFFER_IDX (offset
);
1424 PER_BUFFER_DEFAULT (offset
) = value
;
1426 /* If this variable is not always local in all buffers,
1427 set it in the buffers that don't nominally have a local value. */
1432 for (b
= all_buffers
; b
; b
= b
->next
)
1433 if (!PER_BUFFER_VALUE_P (b
, idx
))
1434 PER_BUFFER_VALUE (b
, offset
) = value
;
1439 return Fset (symbol
, value
);
1445 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1446 doc
: /* Set the default value of variable VAR to VALUE.
1447 VAR, the variable name, is literal (not evaluated);
1448 VALUE is an expression: it is evaluated and its value returned.
1449 The default value of a variable is seen in buffers
1450 that do not have their own values for the variable.
1452 More generally, you can use multiple variables and values, as in
1453 (setq-default VAR VALUE VAR VALUE...)
1454 This sets each VAR's default value to the corresponding VALUE.
1455 The VALUE for the Nth VAR can refer to the new default values
1457 usage: (setq-default [VAR VALUE]...) */)
1460 register Lisp_Object args_left
;
1461 register Lisp_Object val
, symbol
;
1462 struct gcpro gcpro1
;
1472 val
= Feval (Fcar (Fcdr (args_left
)));
1473 symbol
= XCAR (args_left
);
1474 Fset_default (symbol
, val
);
1475 args_left
= Fcdr (XCDR (args_left
));
1477 while (!NILP (args_left
));
1483 /* Lisp functions for creating and removing buffer-local variables. */
1488 union Lisp_Fwd
*fwd
;
1491 static struct Lisp_Buffer_Local_Value
*
1492 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1494 struct Lisp_Buffer_Local_Value
*blv
1495 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1499 XSETSYMBOL (symbol
, sym
);
1500 tem
= Fcons (symbol
, (forwarded
1501 ? do_symval_forwarding (valcontents
.fwd
)
1502 : valcontents
.value
));
1504 /* Buffer_Local_Values cannot have as realval a buffer-local
1505 or keyboard-local forwarding. */
1506 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1507 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1508 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1510 blv
->frame_local
= 0;
1511 blv
->local_if_set
= 0;
1514 SET_BLV_FOUND (blv
, 0);
1518 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1519 1, 1, "vMake Variable Buffer Local: ",
1520 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1521 At any time, the value for the current buffer is in effect,
1522 unless the variable has never been set in this buffer,
1523 in which case the default value is in effect.
1524 Note that binding the variable with `let', or setting it while
1525 a `let'-style binding made in this buffer is in effect,
1526 does not make the variable buffer-local. Return VARIABLE.
1528 In most cases it is better to use `make-local-variable',
1529 which makes a variable local in just one buffer.
1531 The function `default-value' gets the default value and `set-default' sets it. */)
1532 (register Lisp_Object variable
)
1534 struct Lisp_Symbol
*sym
;
1535 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1536 union Lisp_Val_Fwd valcontents
;
1539 CHECK_SYMBOL (variable
);
1540 sym
= XSYMBOL (variable
);
1543 switch (sym
->redirect
)
1545 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1546 case SYMBOL_PLAINVAL
:
1547 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1548 if (EQ (valcontents
.value
, Qunbound
))
1549 valcontents
.value
= Qnil
;
1551 case SYMBOL_LOCALIZED
:
1552 blv
= SYMBOL_BLV (sym
);
1553 if (blv
->frame_local
)
1554 error ("Symbol %s may not be buffer-local",
1555 SDATA (SYMBOL_NAME (variable
)));
1557 case SYMBOL_FORWARDED
:
1558 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1559 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1560 error ("Symbol %s may not be buffer-local",
1561 SDATA (SYMBOL_NAME (variable
)));
1562 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1569 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1573 blv
= make_blv (sym
, forwarded
, valcontents
);
1574 sym
->redirect
= SYMBOL_LOCALIZED
;
1575 SET_SYMBOL_BLV (sym
, blv
);
1578 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1579 if (let_shadows_global_binding_p (symbol
))
1580 message ("Making %s buffer-local while let-bound!",
1581 SDATA (SYMBOL_NAME (variable
)));
1585 blv
->local_if_set
= 1;
1589 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1590 1, 1, "vMake Local Variable: ",
1591 doc
: /* Make VARIABLE have a separate value in the current buffer.
1592 Other buffers will continue to share a common default value.
1593 \(The buffer-local value of VARIABLE starts out as the same value
1594 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1597 If the variable is already arranged to become local when set,
1598 this function causes a local value to exist for this buffer,
1599 just as setting the variable would do.
1601 This function returns VARIABLE, and therefore
1602 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1605 See also `make-variable-buffer-local'.
1607 Do not use `make-local-variable' to make a hook variable buffer-local.
1608 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1609 (register Lisp_Object variable
)
1611 register Lisp_Object tem
;
1613 union Lisp_Val_Fwd valcontents
;
1614 struct Lisp_Symbol
*sym
;
1615 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1617 CHECK_SYMBOL (variable
);
1618 sym
= XSYMBOL (variable
);
1621 switch (sym
->redirect
)
1623 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1624 case SYMBOL_PLAINVAL
:
1625 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1626 case SYMBOL_LOCALIZED
:
1627 blv
= SYMBOL_BLV (sym
);
1628 if (blv
->frame_local
)
1629 error ("Symbol %s may not be buffer-local",
1630 SDATA (SYMBOL_NAME (variable
)));
1632 case SYMBOL_FORWARDED
:
1633 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1634 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1635 error ("Symbol %s may not be buffer-local",
1636 SDATA (SYMBOL_NAME (variable
)));
1642 error ("Symbol %s may not be buffer-local",
1643 SDATA (SYMBOL_NAME (variable
)));
1645 if (blv
? blv
->local_if_set
1646 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1648 tem
= Fboundp (variable
);
1649 /* Make sure the symbol has a local value in this particular buffer,
1650 by setting it to the same value it already has. */
1651 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1656 blv
= make_blv (sym
, forwarded
, valcontents
);
1657 sym
->redirect
= SYMBOL_LOCALIZED
;
1658 SET_SYMBOL_BLV (sym
, blv
);
1661 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1662 if (let_shadows_global_binding_p (symbol
))
1663 message ("Making %s local to %s while let-bound!",
1664 SDATA (SYMBOL_NAME (variable
)),
1665 SDATA (current_buffer
->name
));
1669 /* Make sure this buffer has its own value of symbol. */
1670 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1671 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1674 if (let_shadows_buffer_binding_p (sym
))
1675 message ("Making %s buffer-local while locally let-bound!",
1676 SDATA (SYMBOL_NAME (variable
)));
1678 /* Swap out any local binding for some other buffer, and make
1679 sure the current value is permanently recorded, if it's the
1681 find_symbol_value (variable
);
1683 current_buffer
->local_var_alist
1684 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1685 current_buffer
->local_var_alist
);
1687 /* Make sure symbol does not think it is set up for this buffer;
1688 force it to look once again for this buffer's value. */
1689 if (current_buffer
== XBUFFER (blv
->where
))
1691 /* blv->valcell = blv->defcell;
1692 * SET_BLV_FOUND (blv, 0); */
1696 /* If the symbol forwards into a C variable, then load the binding
1697 for this buffer now. If C code modifies the variable before we
1698 load the binding in, then that new value will clobber the default
1699 binding the next time we unload it. */
1701 swap_in_symval_forwarding (sym
, blv
);
1706 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1707 1, 1, "vKill Local Variable: ",
1708 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1709 From now on the default value will apply in this buffer. Return VARIABLE. */)
1710 (register Lisp_Object variable
)
1712 register Lisp_Object tem
;
1713 struct Lisp_Buffer_Local_Value
*blv
;
1714 struct Lisp_Symbol
*sym
;
1716 CHECK_SYMBOL (variable
);
1717 sym
= XSYMBOL (variable
);
1720 switch (sym
->redirect
)
1722 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1723 case SYMBOL_PLAINVAL
: return variable
;
1724 case SYMBOL_FORWARDED
:
1726 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1727 if (BUFFER_OBJFWDP (valcontents
))
1729 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1730 int idx
= PER_BUFFER_IDX (offset
);
1734 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1735 PER_BUFFER_VALUE (current_buffer
, offset
)
1736 = PER_BUFFER_DEFAULT (offset
);
1741 case SYMBOL_LOCALIZED
:
1742 blv
= SYMBOL_BLV (sym
);
1743 if (blv
->frame_local
)
1749 /* Get rid of this buffer's alist element, if any. */
1750 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1751 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1753 current_buffer
->local_var_alist
1754 = Fdelq (tem
, current_buffer
->local_var_alist
);
1756 /* If the symbol is set up with the current buffer's binding
1757 loaded, recompute its value. We have to do it now, or else
1758 forwarded objects won't work right. */
1760 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1761 if (EQ (buf
, blv
->where
))
1764 /* blv->valcell = blv->defcell;
1765 * SET_BLV_FOUND (blv, 0); */
1767 find_symbol_value (variable
);
1774 /* Lisp functions for creating and removing buffer-local variables. */
1776 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1777 when/if this is removed. */
1779 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1780 1, 1, "vMake Variable Frame Local: ",
1781 doc
: /* Enable VARIABLE to have frame-local bindings.
1782 This does not create any frame-local bindings for VARIABLE,
1783 it just makes them possible.
1785 A frame-local binding is actually a frame parameter value.
1786 If a frame F has a value for the frame parameter named VARIABLE,
1787 that also acts as a frame-local binding for VARIABLE in F--
1788 provided this function has been called to enable VARIABLE
1789 to have frame-local bindings at all.
1791 The only way to create a frame-local binding for VARIABLE in a frame
1792 is to set the VARIABLE frame parameter of that frame. See
1793 `modify-frame-parameters' for how to set frame parameters.
1795 Note that since Emacs 23.1, variables cannot be both buffer-local and
1796 frame-local any more (buffer-local bindings used to take precedence over
1797 frame-local bindings). */)
1798 (register Lisp_Object variable
)
1801 union Lisp_Val_Fwd valcontents
;
1802 struct Lisp_Symbol
*sym
;
1803 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1805 CHECK_SYMBOL (variable
);
1806 sym
= XSYMBOL (variable
);
1809 switch (sym
->redirect
)
1811 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1812 case SYMBOL_PLAINVAL
:
1813 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1814 if (EQ (valcontents
.value
, Qunbound
))
1815 valcontents
.value
= Qnil
;
1817 case SYMBOL_LOCALIZED
:
1818 if (SYMBOL_BLV (sym
)->frame_local
)
1821 error ("Symbol %s may not be frame-local",
1822 SDATA (SYMBOL_NAME (variable
)));
1823 case SYMBOL_FORWARDED
:
1824 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1825 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1826 error ("Symbol %s may not be frame-local",
1827 SDATA (SYMBOL_NAME (variable
)));
1833 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1835 blv
= make_blv (sym
, forwarded
, valcontents
);
1836 blv
->frame_local
= 1;
1837 sym
->redirect
= SYMBOL_LOCALIZED
;
1838 SET_SYMBOL_BLV (sym
, blv
);
1841 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1842 if (let_shadows_global_binding_p (symbol
))
1843 message ("Making %s frame-local while let-bound!",
1844 SDATA (SYMBOL_NAME (variable
)));
1849 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1851 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1852 BUFFER defaults to the current buffer. */)
1853 (register Lisp_Object variable
, Lisp_Object buffer
)
1855 register struct buffer
*buf
;
1856 struct Lisp_Symbol
*sym
;
1859 buf
= current_buffer
;
1862 CHECK_BUFFER (buffer
);
1863 buf
= XBUFFER (buffer
);
1866 CHECK_SYMBOL (variable
);
1867 sym
= XSYMBOL (variable
);
1870 switch (sym
->redirect
)
1872 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1873 case SYMBOL_PLAINVAL
: return Qnil
;
1874 case SYMBOL_LOCALIZED
:
1876 Lisp_Object tail
, elt
, tmp
;
1877 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1878 XSETBUFFER (tmp
, buf
);
1880 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1883 if (EQ (variable
, XCAR (elt
)))
1885 eassert (!blv
->frame_local
);
1886 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1890 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1893 case SYMBOL_FORWARDED
:
1895 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1896 if (BUFFER_OBJFWDP (valcontents
))
1898 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1899 int idx
= PER_BUFFER_IDX (offset
);
1900 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1909 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1911 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1912 More precisely, this means that setting the variable \(with `set' or`setq'),
1913 while it does not have a `let'-style binding that was made in BUFFER,
1914 will produce a buffer local binding. See Info node
1915 `(elisp)Creating Buffer-Local'.
1916 BUFFER defaults to the current buffer. */)
1917 (register Lisp_Object variable
, Lisp_Object buffer
)
1919 struct Lisp_Symbol
*sym
;
1921 CHECK_SYMBOL (variable
);
1922 sym
= XSYMBOL (variable
);
1925 switch (sym
->redirect
)
1927 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1928 case SYMBOL_PLAINVAL
: return Qnil
;
1929 case SYMBOL_LOCALIZED
:
1931 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1932 if (blv
->local_if_set
)
1934 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1935 return Flocal_variable_p (variable
, buffer
);
1937 case SYMBOL_FORWARDED
:
1938 /* All BUFFER_OBJFWD slots become local if they are set. */
1939 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1944 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1946 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1947 If the current binding is buffer-local, the value is the current buffer.
1948 If the current binding is frame-local, the value is the selected frame.
1949 If the current binding is global (the default), the value is nil. */)
1950 (register Lisp_Object variable
)
1952 struct Lisp_Symbol
*sym
;
1954 CHECK_SYMBOL (variable
);
1955 sym
= XSYMBOL (variable
);
1957 /* Make sure the current binding is actually swapped in. */
1958 find_symbol_value (variable
);
1961 switch (sym
->redirect
)
1963 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1964 case SYMBOL_PLAINVAL
: return Qnil
;
1965 case SYMBOL_FORWARDED
:
1967 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1968 if (KBOARD_OBJFWDP (valcontents
))
1969 return Fframe_terminal (Fselected_frame ());
1970 else if (!BUFFER_OBJFWDP (valcontents
))
1974 case SYMBOL_LOCALIZED
:
1975 /* For a local variable, record both the symbol and which
1976 buffer's or frame's value we are saving. */
1977 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1978 return Fcurrent_buffer ();
1979 else if (sym
->redirect
== SYMBOL_LOCALIZED
1980 && BLV_FOUND (SYMBOL_BLV (sym
)))
1981 return SYMBOL_BLV (sym
)->where
;
1988 /* This code is disabled now that we use the selected frame to return
1989 keyboard-local-values. */
1991 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1993 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1994 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1995 If SYMBOL is not a terminal-local variable, then return its normal
1996 value, like `symbol-value'.
1998 TERMINAL may be a terminal object, a frame, or nil (meaning the
1999 selected frame's terminal device). */)
2000 (Lisp_Object symbol
, Lisp_Object terminal
)
2003 struct terminal
*t
= get_terminal (terminal
, 1);
2004 push_kboard (t
->kboard
);
2005 result
= Fsymbol_value (symbol
);
2010 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
2011 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2012 If VARIABLE is not a terminal-local variable, then set its normal
2013 binding, like `set'.
2015 TERMINAL may be a terminal object, a frame, or nil (meaning the
2016 selected frame's terminal device). */)
2017 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2020 struct terminal
*t
= get_terminal (terminal
, 1);
2021 push_kboard (d
->kboard
);
2022 result
= Fset (symbol
, value
);
2028 /* Find the function at the end of a chain of symbol function indirections. */
2030 /* If OBJECT is a symbol, find the end of its function chain and
2031 return the value found there. If OBJECT is not a symbol, just
2032 return it. If there is a cycle in the function chain, signal a
2033 cyclic-function-indirection error.
2035 This is like Findirect_function, except that it doesn't signal an
2036 error if the chain ends up unbound. */
2038 indirect_function (register Lisp_Object object
)
2040 Lisp_Object tortoise
, hare
;
2042 hare
= tortoise
= object
;
2046 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2048 hare
= XSYMBOL (hare
)->function
;
2049 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2051 hare
= XSYMBOL (hare
)->function
;
2053 tortoise
= XSYMBOL (tortoise
)->function
;
2055 if (EQ (hare
, tortoise
))
2056 xsignal1 (Qcyclic_function_indirection
, object
);
2062 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2063 doc
: /* Return the function at the end of OBJECT's function chain.
2064 If OBJECT is not a symbol, just return it. Otherwise, follow all
2065 function indirections to find the final function binding and return it.
2066 If the final symbol in the chain is unbound, signal a void-function error.
2067 Optional arg NOERROR non-nil means to return nil instead of signalling.
2068 Signal a cyclic-function-indirection error if there is a loop in the
2069 function chain of symbols. */)
2070 (register Lisp_Object object
, Lisp_Object noerror
)
2074 /* Optimize for no indirection. */
2076 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2077 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2078 result
= indirect_function (result
);
2079 if (!EQ (result
, Qunbound
))
2083 xsignal1 (Qvoid_function
, object
);
2088 /* Extract and set vector and string elements */
2090 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2091 doc
: /* Return the element of ARRAY at index IDX.
2092 ARRAY may be a vector, a string, a char-table, a bool-vector,
2093 or a byte-code object. IDX starts at 0. */)
2094 (register Lisp_Object array
, Lisp_Object idx
)
2096 register int idxval
;
2099 idxval
= XINT (idx
);
2100 if (STRINGP (array
))
2104 if (idxval
< 0 || idxval
>= SCHARS (array
))
2105 args_out_of_range (array
, idx
);
2106 if (! STRING_MULTIBYTE (array
))
2107 return make_number ((unsigned char) SREF (array
, idxval
));
2108 idxval_byte
= string_char_to_byte (array
, idxval
);
2110 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2111 return make_number (c
);
2113 else if (BOOL_VECTOR_P (array
))
2117 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2118 args_out_of_range (array
, idx
);
2120 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2121 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2123 else if (CHAR_TABLE_P (array
))
2125 CHECK_CHARACTER (idx
);
2126 return CHAR_TABLE_REF (array
, idxval
);
2131 if (VECTORP (array
))
2132 size
= ASIZE (array
);
2133 else if (FUNVECP (array
))
2134 size
= FUNVEC_SIZE (array
);
2136 wrong_type_argument (Qarrayp
, array
);
2138 if (idxval
< 0 || idxval
>= size
)
2139 args_out_of_range (array
, idx
);
2140 return AREF (array
, idxval
);
2144 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2145 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2146 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2147 bool-vector. IDX starts at 0. */)
2148 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2150 register int idxval
;
2153 idxval
= XINT (idx
);
2154 CHECK_ARRAY (array
, Qarrayp
);
2155 CHECK_IMPURE (array
);
2157 if (VECTORP (array
))
2159 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2160 args_out_of_range (array
, idx
);
2161 XVECTOR (array
)->contents
[idxval
] = newelt
;
2163 else if (BOOL_VECTOR_P (array
))
2167 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2168 args_out_of_range (array
, idx
);
2170 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2172 if (! NILP (newelt
))
2173 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2175 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2176 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2178 else if (CHAR_TABLE_P (array
))
2180 CHECK_CHARACTER (idx
);
2181 CHAR_TABLE_SET (array
, idxval
, newelt
);
2183 else if (STRING_MULTIBYTE (array
))
2185 int idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2186 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2188 if (idxval
< 0 || idxval
>= SCHARS (array
))
2189 args_out_of_range (array
, idx
);
2190 CHECK_CHARACTER (newelt
);
2192 nbytes
= SBYTES (array
);
2194 idxval_byte
= string_char_to_byte (array
, idxval
);
2195 p1
= SDATA (array
) + idxval_byte
;
2196 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2197 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2198 if (prev_bytes
!= new_bytes
)
2200 /* We must relocate the string data. */
2201 int nchars
= SCHARS (array
);
2205 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2206 memcpy (str
, SDATA (array
), nbytes
);
2207 allocate_string_data (XSTRING (array
), nchars
,
2208 nbytes
+ new_bytes
- prev_bytes
);
2209 memcpy (SDATA (array
), str
, idxval_byte
);
2210 p1
= SDATA (array
) + idxval_byte
;
2211 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2212 nbytes
- (idxval_byte
+ prev_bytes
));
2214 clear_string_char_byte_cache ();
2221 if (idxval
< 0 || idxval
>= SCHARS (array
))
2222 args_out_of_range (array
, idx
);
2223 CHECK_NUMBER (newelt
);
2225 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2229 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2230 if (SREF (array
, i
) >= 0x80)
2231 args_out_of_range (array
, newelt
);
2232 /* ARRAY is an ASCII string. Convert it to a multibyte
2233 string, and try `aset' again. */
2234 STRING_SET_MULTIBYTE (array
);
2235 return Faset (array
, idx
, newelt
);
2237 SSET (array
, idxval
, XINT (newelt
));
2243 /* Arithmetic functions */
2245 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2248 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2250 double f1
= 0, f2
= 0;
2253 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2254 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2256 if (FLOATP (num1
) || FLOATP (num2
))
2259 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2260 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2266 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2271 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2276 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2281 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2286 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2291 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2300 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2301 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2302 (register Lisp_Object num1
, Lisp_Object num2
)
2304 return arithcompare (num1
, num2
, equal
);
2307 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2308 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2309 (register Lisp_Object num1
, Lisp_Object num2
)
2311 return arithcompare (num1
, num2
, less
);
2314 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2315 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2316 (register Lisp_Object num1
, Lisp_Object num2
)
2318 return arithcompare (num1
, num2
, grtr
);
2321 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2322 doc
: /* Return t if first arg is less than or equal to second arg.
2323 Both must be numbers or markers. */)
2324 (register Lisp_Object num1
, Lisp_Object num2
)
2326 return arithcompare (num1
, num2
, less_or_equal
);
2329 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2330 doc
: /* Return t if first arg is greater than or equal to second arg.
2331 Both must be numbers or markers. */)
2332 (register Lisp_Object num1
, Lisp_Object num2
)
2334 return arithcompare (num1
, num2
, grtr_or_equal
);
2337 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2338 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2339 (register Lisp_Object num1
, Lisp_Object num2
)
2341 return arithcompare (num1
, num2
, notequal
);
2344 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2345 doc
: /* Return t if NUMBER is zero. */)
2346 (register Lisp_Object number
)
2348 CHECK_NUMBER_OR_FLOAT (number
);
2350 if (FLOATP (number
))
2352 if (XFLOAT_DATA (number
) == 0.0)
2362 /* Convert between long values and pairs of Lisp integers.
2363 Note that long_to_cons returns a single Lisp integer
2364 when the value fits in one. */
2367 long_to_cons (long unsigned int i
)
2369 unsigned long top
= i
>> 16;
2370 unsigned int bot
= i
& 0xFFFF;
2372 return make_number (bot
);
2373 if (top
== (unsigned long)-1 >> 16)
2374 return Fcons (make_number (-1), make_number (bot
));
2375 return Fcons (make_number (top
), make_number (bot
));
2379 cons_to_long (Lisp_Object c
)
2381 Lisp_Object top
, bot
;
2388 return ((XINT (top
) << 16) | XINT (bot
));
2391 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2392 doc
: /* Return the decimal representation of NUMBER as a string.
2393 Uses a minus sign if negative.
2394 NUMBER may be an integer or a floating point number. */)
2395 (Lisp_Object number
)
2397 char buffer
[VALBITS
];
2399 CHECK_NUMBER_OR_FLOAT (number
);
2401 if (FLOATP (number
))
2403 char pigbuf
[350]; /* see comments in float_to_string */
2405 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2406 return build_string (pigbuf
);
2409 if (sizeof (int) == sizeof (EMACS_INT
))
2410 sprintf (buffer
, "%d", (int) XINT (number
));
2411 else if (sizeof (long) == sizeof (EMACS_INT
))
2412 sprintf (buffer
, "%ld", (long) XINT (number
));
2415 return build_string (buffer
);
2419 digit_to_number (int character
, int base
)
2423 if (character
>= '0' && character
<= '9')
2424 digit
= character
- '0';
2425 else if (character
>= 'a' && character
<= 'z')
2426 digit
= character
- 'a' + 10;
2427 else if (character
>= 'A' && character
<= 'Z')
2428 digit
= character
- 'A' + 10;
2438 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2439 doc
: /* Parse STRING as a decimal number and return the number.
2440 This parses both integers and floating point numbers.
2441 It ignores leading spaces and tabs, and all trailing chars.
2443 If BASE, interpret STRING as a number in that base. If BASE isn't
2444 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2445 If the base used is not 10, STRING is always parsed as integer. */)
2446 (register Lisp_Object string
, Lisp_Object base
)
2448 register unsigned char *p
;
2453 CHECK_STRING (string
);
2459 CHECK_NUMBER (base
);
2461 if (b
< 2 || b
> 16)
2462 xsignal1 (Qargs_out_of_range
, base
);
2465 /* Skip any whitespace at the front of the number. Some versions of
2466 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2468 while (*p
== ' ' || *p
== '\t')
2479 if (isfloat_string (p
, 1) && b
== 10)
2480 val
= make_float (sign
* atof (p
));
2487 int digit
= digit_to_number (*p
++, b
);
2493 val
= make_fixnum_or_float (sign
* v
);
2513 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2514 int, Lisp_Object
*);
2515 extern Lisp_Object
fmod_float (Lisp_Object
, Lisp_Object
);
2518 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2520 register Lisp_Object val
;
2521 register int argnum
;
2522 register EMACS_INT accum
= 0;
2523 register EMACS_INT next
;
2525 switch (SWITCH_ENUM_CAST (code
))
2543 for (argnum
= 0; argnum
< nargs
; argnum
++)
2545 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2547 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2550 return float_arith_driver ((double) accum
, argnum
, code
,
2553 next
= XINT (args
[argnum
]);
2554 switch (SWITCH_ENUM_CAST (code
))
2560 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2571 xsignal0 (Qarith_error
);
2585 if (!argnum
|| next
> accum
)
2589 if (!argnum
|| next
< accum
)
2595 XSETINT (val
, accum
);
2600 #define isnan(x) ((x) != (x))
2603 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2605 register Lisp_Object val
;
2608 for (; argnum
< nargs
; argnum
++)
2610 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2611 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2615 next
= XFLOAT_DATA (val
);
2619 args
[argnum
] = val
; /* runs into a compiler bug. */
2620 next
= XINT (args
[argnum
]);
2622 switch (SWITCH_ENUM_CAST (code
))
2628 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2638 if (! IEEE_FLOATING_POINT
&& next
== 0)
2639 xsignal0 (Qarith_error
);
2646 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2648 if (!argnum
|| isnan (next
) || next
> accum
)
2652 if (!argnum
|| isnan (next
) || next
< accum
)
2658 return make_float (accum
);
2662 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2663 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2664 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2665 (int nargs
, Lisp_Object
*args
)
2667 return arith_driver (Aadd
, nargs
, args
);
2670 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2671 doc
: /* Negate number or subtract numbers or markers and return the result.
2672 With one arg, negates it. With more than one arg,
2673 subtracts all but the first from the first.
2674 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2675 (int nargs
, Lisp_Object
*args
)
2677 return arith_driver (Asub
, nargs
, args
);
2680 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2681 doc
: /* Return product of any number of arguments, which are numbers or markers.
2682 usage: (* &rest NUMBERS-OR-MARKERS) */)
2683 (int nargs
, Lisp_Object
*args
)
2685 return arith_driver (Amult
, nargs
, args
);
2688 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2689 doc
: /* Return first argument divided by all the remaining arguments.
2690 The arguments must be numbers or markers.
2691 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2692 (int nargs
, Lisp_Object
*args
)
2695 for (argnum
= 2; argnum
< nargs
; argnum
++)
2696 if (FLOATP (args
[argnum
]))
2697 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2698 return arith_driver (Adiv
, nargs
, args
);
2701 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2702 doc
: /* Return remainder of X divided by Y.
2703 Both must be integers or markers. */)
2704 (register Lisp_Object x
, Lisp_Object y
)
2708 CHECK_NUMBER_COERCE_MARKER (x
);
2709 CHECK_NUMBER_COERCE_MARKER (y
);
2711 if (XFASTINT (y
) == 0)
2712 xsignal0 (Qarith_error
);
2714 XSETINT (val
, XINT (x
) % XINT (y
));
2728 /* If the magnitude of the result exceeds that of the divisor, or
2729 the sign of the result does not agree with that of the dividend,
2730 iterate with the reduced value. This does not yield a
2731 particularly accurate result, but at least it will be in the
2732 range promised by fmod. */
2734 r
-= f2
* floor (r
/ f2
);
2735 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2739 #endif /* ! HAVE_FMOD */
2741 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2742 doc
: /* Return X modulo Y.
2743 The result falls between zero (inclusive) and Y (exclusive).
2744 Both X and Y must be numbers or markers. */)
2745 (register Lisp_Object x
, Lisp_Object y
)
2750 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2751 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2753 if (FLOATP (x
) || FLOATP (y
))
2754 return fmod_float (x
, y
);
2760 xsignal0 (Qarith_error
);
2764 /* If the "remainder" comes out with the wrong sign, fix it. */
2765 if (i2
< 0 ? i1
> 0 : i1
< 0)
2772 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2773 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2774 The value is always a number; markers are converted to numbers.
2775 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2776 (int nargs
, Lisp_Object
*args
)
2778 return arith_driver (Amax
, nargs
, args
);
2781 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2782 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2783 The value is always a number; markers are converted to numbers.
2784 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2785 (int nargs
, Lisp_Object
*args
)
2787 return arith_driver (Amin
, nargs
, args
);
2790 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2791 doc
: /* Return bitwise-and of all the arguments.
2792 Arguments may be integers, or markers converted to integers.
2793 usage: (logand &rest INTS-OR-MARKERS) */)
2794 (int nargs
, Lisp_Object
*args
)
2796 return arith_driver (Alogand
, nargs
, args
);
2799 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2800 doc
: /* Return bitwise-or of all the arguments.
2801 Arguments may be integers, or markers converted to integers.
2802 usage: (logior &rest INTS-OR-MARKERS) */)
2803 (int nargs
, Lisp_Object
*args
)
2805 return arith_driver (Alogior
, nargs
, args
);
2808 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2809 doc
: /* Return bitwise-exclusive-or of all the arguments.
2810 Arguments may be integers, or markers converted to integers.
2811 usage: (logxor &rest INTS-OR-MARKERS) */)
2812 (int nargs
, Lisp_Object
*args
)
2814 return arith_driver (Alogxor
, nargs
, args
);
2817 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2818 doc
: /* Return VALUE with its bits shifted left by COUNT.
2819 If COUNT is negative, shifting is actually to the right.
2820 In this case, the sign bit is duplicated. */)
2821 (register Lisp_Object value
, Lisp_Object count
)
2823 register Lisp_Object val
;
2825 CHECK_NUMBER (value
);
2826 CHECK_NUMBER (count
);
2828 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2830 else if (XINT (count
) > 0)
2831 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2832 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2833 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2835 XSETINT (val
, XINT (value
) >> -XINT (count
));
2839 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2840 doc
: /* Return VALUE with its bits shifted left by COUNT.
2841 If COUNT is negative, shifting is actually to the right.
2842 In this case, zeros are shifted in on the left. */)
2843 (register Lisp_Object value
, Lisp_Object count
)
2845 register Lisp_Object val
;
2847 CHECK_NUMBER (value
);
2848 CHECK_NUMBER (count
);
2850 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2852 else if (XINT (count
) > 0)
2853 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2854 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2857 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2861 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2862 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2863 Markers are converted to integers. */)
2864 (register Lisp_Object number
)
2866 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2868 if (FLOATP (number
))
2869 return (make_float (1.0 + XFLOAT_DATA (number
)));
2871 XSETINT (number
, XINT (number
) + 1);
2875 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2876 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2877 Markers are converted to integers. */)
2878 (register Lisp_Object number
)
2880 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2882 if (FLOATP (number
))
2883 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2885 XSETINT (number
, XINT (number
) - 1);
2889 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2890 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2891 (register Lisp_Object number
)
2893 CHECK_NUMBER (number
);
2894 XSETINT (number
, ~XINT (number
));
2898 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2899 doc
: /* Return the byteorder for the machine.
2900 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2901 lowercase l) for small endian machines. */)
2904 unsigned i
= 0x04030201;
2905 int order
= *(char *)&i
== 1 ? 108 : 66;
2907 return make_number (order
);
2915 Lisp_Object error_tail
, arith_tail
;
2917 Qquote
= intern_c_string ("quote");
2918 Qlambda
= intern_c_string ("lambda");
2919 Qsubr
= intern_c_string ("subr");
2920 Qerror_conditions
= intern_c_string ("error-conditions");
2921 Qerror_message
= intern_c_string ("error-message");
2922 Qtop_level
= intern_c_string ("top-level");
2924 Qerror
= intern_c_string ("error");
2925 Qquit
= intern_c_string ("quit");
2926 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2927 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2928 Qvoid_function
= intern_c_string ("void-function");
2929 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2930 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2931 Qvoid_variable
= intern_c_string ("void-variable");
2932 Qsetting_constant
= intern_c_string ("setting-constant");
2933 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2935 Qinvalid_function
= intern_c_string ("invalid-function");
2936 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2937 Qno_catch
= intern_c_string ("no-catch");
2938 Qend_of_file
= intern_c_string ("end-of-file");
2939 Qarith_error
= intern_c_string ("arith-error");
2940 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2941 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2942 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2943 Qtext_read_only
= intern_c_string ("text-read-only");
2944 Qmark_inactive
= intern_c_string ("mark-inactive");
2946 Qlistp
= intern_c_string ("listp");
2947 Qconsp
= intern_c_string ("consp");
2948 Qsymbolp
= intern_c_string ("symbolp");
2949 Qkeywordp
= intern_c_string ("keywordp");
2950 Qintegerp
= intern_c_string ("integerp");
2951 Qnatnump
= intern_c_string ("natnump");
2952 Qwholenump
= intern_c_string ("wholenump");
2953 Qstringp
= intern_c_string ("stringp");
2954 Qarrayp
= intern_c_string ("arrayp");
2955 Qsequencep
= intern_c_string ("sequencep");
2956 Qbufferp
= intern_c_string ("bufferp");
2957 Qvectorp
= intern_c_string ("vectorp");
2958 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2959 Qmarkerp
= intern_c_string ("markerp");
2960 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2961 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2962 Qboundp
= intern_c_string ("boundp");
2963 Qfboundp
= intern_c_string ("fboundp");
2965 Qfloatp
= intern_c_string ("floatp");
2966 Qnumberp
= intern_c_string ("numberp");
2967 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2969 Qchar_table_p
= intern_c_string ("char-table-p");
2970 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2972 Qsubrp
= intern_c_string ("subrp");
2973 Qunevalled
= intern_c_string ("unevalled");
2974 Qmany
= intern_c_string ("many");
2976 Qcdr
= intern_c_string ("cdr");
2978 /* Handle automatic advice activation */
2979 Qad_advice_info
= intern_c_string ("ad-advice-info");
2980 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2982 error_tail
= pure_cons (Qerror
, Qnil
);
2984 /* ERROR is used as a signaler for random errors for which nothing else is right */
2986 Fput (Qerror
, Qerror_conditions
,
2988 Fput (Qerror
, Qerror_message
,
2989 make_pure_c_string ("error"));
2991 Fput (Qquit
, Qerror_conditions
,
2992 pure_cons (Qquit
, Qnil
));
2993 Fput (Qquit
, Qerror_message
,
2994 make_pure_c_string ("Quit"));
2996 Fput (Qwrong_type_argument
, Qerror_conditions
,
2997 pure_cons (Qwrong_type_argument
, error_tail
));
2998 Fput (Qwrong_type_argument
, Qerror_message
,
2999 make_pure_c_string ("Wrong type argument"));
3001 Fput (Qargs_out_of_range
, Qerror_conditions
,
3002 pure_cons (Qargs_out_of_range
, error_tail
));
3003 Fput (Qargs_out_of_range
, Qerror_message
,
3004 make_pure_c_string ("Args out of range"));
3006 Fput (Qvoid_function
, Qerror_conditions
,
3007 pure_cons (Qvoid_function
, error_tail
));
3008 Fput (Qvoid_function
, Qerror_message
,
3009 make_pure_c_string ("Symbol's function definition is void"));
3011 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
3012 pure_cons (Qcyclic_function_indirection
, error_tail
));
3013 Fput (Qcyclic_function_indirection
, Qerror_message
,
3014 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3016 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
3017 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3018 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3019 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3021 Qcircular_list
= intern_c_string ("circular-list");
3022 staticpro (&Qcircular_list
);
3023 Fput (Qcircular_list
, Qerror_conditions
,
3024 pure_cons (Qcircular_list
, error_tail
));
3025 Fput (Qcircular_list
, Qerror_message
,
3026 make_pure_c_string ("List contains a loop"));
3028 Fput (Qvoid_variable
, Qerror_conditions
,
3029 pure_cons (Qvoid_variable
, error_tail
));
3030 Fput (Qvoid_variable
, Qerror_message
,
3031 make_pure_c_string ("Symbol's value as variable is void"));
3033 Fput (Qsetting_constant
, Qerror_conditions
,
3034 pure_cons (Qsetting_constant
, error_tail
));
3035 Fput (Qsetting_constant
, Qerror_message
,
3036 make_pure_c_string ("Attempt to set a constant symbol"));
3038 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3039 pure_cons (Qinvalid_read_syntax
, error_tail
));
3040 Fput (Qinvalid_read_syntax
, Qerror_message
,
3041 make_pure_c_string ("Invalid read syntax"));
3043 Fput (Qinvalid_function
, Qerror_conditions
,
3044 pure_cons (Qinvalid_function
, error_tail
));
3045 Fput (Qinvalid_function
, Qerror_message
,
3046 make_pure_c_string ("Invalid function"));
3048 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3049 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3050 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3051 make_pure_c_string ("Wrong number of arguments"));
3053 Fput (Qno_catch
, Qerror_conditions
,
3054 pure_cons (Qno_catch
, error_tail
));
3055 Fput (Qno_catch
, Qerror_message
,
3056 make_pure_c_string ("No catch for tag"));
3058 Fput (Qend_of_file
, Qerror_conditions
,
3059 pure_cons (Qend_of_file
, error_tail
));
3060 Fput (Qend_of_file
, Qerror_message
,
3061 make_pure_c_string ("End of file during parsing"));
3063 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3064 Fput (Qarith_error
, Qerror_conditions
,
3066 Fput (Qarith_error
, Qerror_message
,
3067 make_pure_c_string ("Arithmetic error"));
3069 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3070 pure_cons (Qbeginning_of_buffer
, error_tail
));
3071 Fput (Qbeginning_of_buffer
, Qerror_message
,
3072 make_pure_c_string ("Beginning of buffer"));
3074 Fput (Qend_of_buffer
, Qerror_conditions
,
3075 pure_cons (Qend_of_buffer
, error_tail
));
3076 Fput (Qend_of_buffer
, Qerror_message
,
3077 make_pure_c_string ("End of buffer"));
3079 Fput (Qbuffer_read_only
, Qerror_conditions
,
3080 pure_cons (Qbuffer_read_only
, error_tail
));
3081 Fput (Qbuffer_read_only
, Qerror_message
,
3082 make_pure_c_string ("Buffer is read-only"));
3084 Fput (Qtext_read_only
, Qerror_conditions
,
3085 pure_cons (Qtext_read_only
, error_tail
));
3086 Fput (Qtext_read_only
, Qerror_message
,
3087 make_pure_c_string ("Text is read-only"));
3089 Qrange_error
= intern_c_string ("range-error");
3090 Qdomain_error
= intern_c_string ("domain-error");
3091 Qsingularity_error
= intern_c_string ("singularity-error");
3092 Qoverflow_error
= intern_c_string ("overflow-error");
3093 Qunderflow_error
= intern_c_string ("underflow-error");
3095 Fput (Qdomain_error
, Qerror_conditions
,
3096 pure_cons (Qdomain_error
, arith_tail
));
3097 Fput (Qdomain_error
, Qerror_message
,
3098 make_pure_c_string ("Arithmetic domain error"));
3100 Fput (Qrange_error
, Qerror_conditions
,
3101 pure_cons (Qrange_error
, arith_tail
));
3102 Fput (Qrange_error
, Qerror_message
,
3103 make_pure_c_string ("Arithmetic range error"));
3105 Fput (Qsingularity_error
, Qerror_conditions
,
3106 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3107 Fput (Qsingularity_error
, Qerror_message
,
3108 make_pure_c_string ("Arithmetic singularity error"));
3110 Fput (Qoverflow_error
, Qerror_conditions
,
3111 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3112 Fput (Qoverflow_error
, Qerror_message
,
3113 make_pure_c_string ("Arithmetic overflow error"));
3115 Fput (Qunderflow_error
, Qerror_conditions
,
3116 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3117 Fput (Qunderflow_error
, Qerror_message
,
3118 make_pure_c_string ("Arithmetic underflow error"));
3120 staticpro (&Qrange_error
);
3121 staticpro (&Qdomain_error
);
3122 staticpro (&Qsingularity_error
);
3123 staticpro (&Qoverflow_error
);
3124 staticpro (&Qunderflow_error
);
3128 staticpro (&Qquote
);
3129 staticpro (&Qlambda
);
3131 staticpro (&Qunbound
);
3132 staticpro (&Qerror_conditions
);
3133 staticpro (&Qerror_message
);
3134 staticpro (&Qtop_level
);
3136 staticpro (&Qerror
);
3138 staticpro (&Qwrong_type_argument
);
3139 staticpro (&Qargs_out_of_range
);
3140 staticpro (&Qvoid_function
);
3141 staticpro (&Qcyclic_function_indirection
);
3142 staticpro (&Qcyclic_variable_indirection
);
3143 staticpro (&Qvoid_variable
);
3144 staticpro (&Qsetting_constant
);
3145 staticpro (&Qinvalid_read_syntax
);
3146 staticpro (&Qwrong_number_of_arguments
);
3147 staticpro (&Qinvalid_function
);
3148 staticpro (&Qno_catch
);
3149 staticpro (&Qend_of_file
);
3150 staticpro (&Qarith_error
);
3151 staticpro (&Qbeginning_of_buffer
);
3152 staticpro (&Qend_of_buffer
);
3153 staticpro (&Qbuffer_read_only
);
3154 staticpro (&Qtext_read_only
);
3155 staticpro (&Qmark_inactive
);
3157 staticpro (&Qlistp
);
3158 staticpro (&Qconsp
);
3159 staticpro (&Qsymbolp
);
3160 staticpro (&Qkeywordp
);
3161 staticpro (&Qintegerp
);
3162 staticpro (&Qnatnump
);
3163 staticpro (&Qwholenump
);
3164 staticpro (&Qstringp
);
3165 staticpro (&Qarrayp
);
3166 staticpro (&Qsequencep
);
3167 staticpro (&Qbufferp
);
3168 staticpro (&Qvectorp
);
3169 staticpro (&Qchar_or_string_p
);
3170 staticpro (&Qmarkerp
);
3171 staticpro (&Qbuffer_or_string_p
);
3172 staticpro (&Qinteger_or_marker_p
);
3173 staticpro (&Qfloatp
);
3174 staticpro (&Qnumberp
);
3175 staticpro (&Qnumber_or_marker_p
);
3176 staticpro (&Qchar_table_p
);
3177 staticpro (&Qvector_or_char_table_p
);
3178 staticpro (&Qsubrp
);
3180 staticpro (&Qunevalled
);
3182 staticpro (&Qboundp
);
3183 staticpro (&Qfboundp
);
3185 staticpro (&Qad_advice_info
);
3186 staticpro (&Qad_activate_internal
);
3188 /* Types that type-of returns. */
3189 Qinteger
= intern_c_string ("integer");
3190 Qsymbol
= intern_c_string ("symbol");
3191 Qstring
= intern_c_string ("string");
3192 Qcons
= intern_c_string ("cons");
3193 Qmarker
= intern_c_string ("marker");
3194 Qoverlay
= intern_c_string ("overlay");
3195 Qfloat
= intern_c_string ("float");
3196 Qwindow_configuration
= intern_c_string ("window-configuration");
3197 Qprocess
= intern_c_string ("process");
3198 Qwindow
= intern_c_string ("window");
3199 /* Qsubr = intern_c_string ("subr"); */
3200 Qcompiled_function
= intern_c_string ("compiled-function");
3201 Qfunction_vector
= intern_c_string ("function-vector");
3202 Qbuffer
= intern_c_string ("buffer");
3203 Qframe
= intern_c_string ("frame");
3204 Qvector
= intern_c_string ("vector");
3205 Qchar_table
= intern_c_string ("char-table");
3206 Qbool_vector
= intern_c_string ("bool-vector");
3207 Qhash_table
= intern_c_string ("hash-table");
3209 DEFSYM (Qfont_spec
, "font-spec");
3210 DEFSYM (Qfont_entity
, "font-entity");
3211 DEFSYM (Qfont_object
, "font-object");
3213 DEFSYM (Qinteractive_form
, "interactive-form");
3215 staticpro (&Qinteger
);
3216 staticpro (&Qsymbol
);
3217 staticpro (&Qstring
);
3219 staticpro (&Qmarker
);
3220 staticpro (&Qoverlay
);
3221 staticpro (&Qfloat
);
3222 staticpro (&Qwindow_configuration
);
3223 staticpro (&Qprocess
);
3224 staticpro (&Qwindow
);
3225 /* staticpro (&Qsubr); */
3226 staticpro (&Qcompiled_function
);
3227 staticpro (&Qfunction_vector
);
3228 staticpro (&Qbuffer
);
3229 staticpro (&Qframe
);
3230 staticpro (&Qvector
);
3231 staticpro (&Qchar_table
);
3232 staticpro (&Qbool_vector
);
3233 staticpro (&Qhash_table
);
3235 defsubr (&Sindirect_variable
);
3236 defsubr (&Sinteractive_form
);
3239 defsubr (&Stype_of
);
3244 defsubr (&Sintegerp
);
3245 defsubr (&Sinteger_or_marker_p
);
3246 defsubr (&Snumberp
);
3247 defsubr (&Snumber_or_marker_p
);
3249 defsubr (&Snatnump
);
3250 defsubr (&Ssymbolp
);
3251 defsubr (&Skeywordp
);
3252 defsubr (&Sstringp
);
3253 defsubr (&Smultibyte_string_p
);
3254 defsubr (&Svectorp
);
3255 defsubr (&Schar_table_p
);
3256 defsubr (&Svector_or_char_table_p
);
3257 defsubr (&Sbool_vector_p
);
3259 defsubr (&Ssequencep
);
3260 defsubr (&Sbufferp
);
3261 defsubr (&Smarkerp
);
3263 defsubr (&Sbyte_code_function_p
);
3264 defsubr (&Sfunvecp
);
3265 defsubr (&Schar_or_string_p
);
3268 defsubr (&Scar_safe
);
3269 defsubr (&Scdr_safe
);
3272 defsubr (&Ssymbol_function
);
3273 defsubr (&Sindirect_function
);
3274 defsubr (&Ssymbol_plist
);
3275 defsubr (&Ssymbol_name
);
3276 defsubr (&Smakunbound
);
3277 defsubr (&Sfmakunbound
);
3279 defsubr (&Sfboundp
);
3281 defsubr (&Sdefalias
);
3282 defsubr (&Ssetplist
);
3283 defsubr (&Ssymbol_value
);
3285 defsubr (&Sdefault_boundp
);
3286 defsubr (&Sdefault_value
);
3287 defsubr (&Sset_default
);
3288 defsubr (&Ssetq_default
);
3289 defsubr (&Smake_variable_buffer_local
);
3290 defsubr (&Smake_local_variable
);
3291 defsubr (&Skill_local_variable
);
3292 defsubr (&Smake_variable_frame_local
);
3293 defsubr (&Slocal_variable_p
);
3294 defsubr (&Slocal_variable_if_set_p
);
3295 defsubr (&Svariable_binding_locus
);
3296 #if 0 /* XXX Remove this. --lorentey */
3297 defsubr (&Sterminal_local_value
);
3298 defsubr (&Sset_terminal_local_value
);
3302 defsubr (&Snumber_to_string
);
3303 defsubr (&Sstring_to_number
);
3304 defsubr (&Seqlsign
);
3327 defsubr (&Sbyteorder
);
3328 defsubr (&Ssubr_arity
);
3329 defsubr (&Ssubr_name
);
3331 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3333 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum
,
3334 doc
: /* The largest value that is representable in a Lisp integer. */);
3335 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3336 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3338 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum
,
3339 doc
: /* The smallest value that is representable in a Lisp integer. */);
3340 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3341 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3345 arith_error (int signo
)
3347 sigsetmask (SIGEMPTYMASK
);
3349 SIGNAL_THREAD_CHECK (signo
);
3350 xsignal0 (Qarith_error
);
3356 /* Don't do this if just dumping out.
3357 We don't want to call `signal' in this case
3358 so that we don't have trouble with dumping
3359 signal-delivering routines in an inconsistent state. */
3363 #endif /* CANNOT_DUMP */
3364 signal (SIGFPE
, arith_error
);
3367 signal (SIGEMT
, arith_error
);
3371 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3372 (do not change this comment) */