I started to clean this up and make it work under System V, until I hit a wall.
[emacs.git] / src / data.c
blobc9cc6bad3846d650681ba1386343ab0cf7df48e2
1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
9 any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
21 #include <signal.h>
23 #include "config.h"
24 #include "lisp.h"
25 #include "puresize.h"
27 #ifndef standalone
28 #include "buffer.h"
29 #endif
31 #include "syssignal.h"
33 #ifdef LISP_FLOAT_TYPE
34 #include <math.h>
35 #endif /* LISP_FLOAT_TYPE */
37 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
38 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
39 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
40 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
41 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
42 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
43 Lisp_Object Qend_of_file, Qarith_error;
44 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
45 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qlistp, Qconsp;
46 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
47 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
48 Lisp_Object Qbuffer_or_string_p;
49 Lisp_Object Qboundp, Qfboundp;
50 Lisp_Object Qcdr;
52 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
53 Lisp_Object Qoverflow_error, Qunderflow_error;
55 #ifdef LISP_FLOAT_TYPE
56 Lisp_Object Qfloatp;
57 Lisp_Object Qnumberp, Qnumber_or_marker_p;
58 #endif
60 static Lisp_Object swap_in_symval_forwarding ();
62 Lisp_Object
63 wrong_type_argument (predicate, value)
64 register Lisp_Object predicate, value;
66 register Lisp_Object tem;
69 if (!EQ (Vmocklisp_arguments, Qt))
71 if (XTYPE (value) == Lisp_String &&
72 (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
73 return Fstring_to_number (value);
74 if (XTYPE (value) == Lisp_Int && EQ (predicate, Qstringp))
75 return Fnumber_to_string (value);
77 value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
78 tem = call1 (predicate, value);
80 while (NILP (tem));
81 return value;
84 pure_write_error ()
86 error ("Attempt to modify read-only object");
89 void
90 args_out_of_range (a1, a2)
91 Lisp_Object a1, a2;
93 while (1)
94 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
97 void
98 args_out_of_range_3 (a1, a2, a3)
99 Lisp_Object a1, a2, a3;
101 while (1)
102 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
105 Lisp_Object
106 make_number (num)
107 int num;
109 register Lisp_Object val;
110 XSET (val, Lisp_Int, num);
111 return val;
114 /* On some machines, XINT needs a temporary location.
115 Here it is, in case it is needed. */
117 int sign_extend_temp;
119 /* On a few machines, XINT can only be done by calling this. */
122 sign_extend_lisp_int (num)
123 int num;
125 if (num & (1 << (VALBITS - 1)))
126 return num | ((-1) << VALBITS);
127 else
128 return num & ((1 << VALBITS) - 1);
131 /* Data type predicates */
133 DEFUN ("eq", Feq, Seq, 2, 2, 0,
134 "T if the two args are the same Lisp object.")
135 (obj1, obj2)
136 Lisp_Object obj1, obj2;
138 if (EQ (obj1, obj2))
139 return Qt;
140 return Qnil;
143 DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
144 (obj)
145 Lisp_Object obj;
147 if (NILP (obj))
148 return Qt;
149 return Qnil;
152 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
153 (obj)
154 Lisp_Object obj;
156 if (XTYPE (obj) == Lisp_Cons)
157 return Qt;
158 return Qnil;
161 DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
162 (obj)
163 Lisp_Object obj;
165 if (XTYPE (obj) == Lisp_Cons)
166 return Qnil;
167 return Qt;
170 DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
171 (obj)
172 Lisp_Object obj;
174 if (XTYPE (obj) == Lisp_Cons || NILP (obj))
175 return Qt;
176 return Qnil;
179 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
180 (obj)
181 Lisp_Object obj;
183 if (XTYPE (obj) == Lisp_Cons || NILP (obj))
184 return Qnil;
185 return Qt;
188 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
189 (obj)
190 Lisp_Object obj;
192 if (XTYPE (obj) == Lisp_Symbol)
193 return Qt;
194 return Qnil;
197 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
198 (obj)
199 Lisp_Object obj;
201 if (XTYPE (obj) == Lisp_Vector)
202 return Qt;
203 return Qnil;
206 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
207 (obj)
208 Lisp_Object obj;
210 if (XTYPE (obj) == Lisp_String)
211 return Qt;
212 return Qnil;
215 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
216 (obj)
217 Lisp_Object obj;
219 if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
220 return Qt;
221 return Qnil;
224 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
225 "T if OBJECT is a sequence (list or array).")
226 (obj)
227 register Lisp_Object obj;
229 if (CONSP (obj) || NILP (obj) ||
230 XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
231 return Qt;
232 return Qnil;
235 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
236 (obj)
237 Lisp_Object obj;
239 if (XTYPE (obj) == Lisp_Buffer)
240 return Qt;
241 return Qnil;
244 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
245 (obj)
246 Lisp_Object obj;
248 if (XTYPE (obj) == Lisp_Marker)
249 return Qt;
250 return Qnil;
253 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
254 (obj)
255 Lisp_Object obj;
257 if (XTYPE (obj) == Lisp_Subr)
258 return Qt;
259 return Qnil;
262 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
263 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
264 (obj)
265 Lisp_Object obj;
267 if (XTYPE (obj) == Lisp_Compiled)
268 return Qt;
269 return Qnil;
272 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, "T if OBJECT is a character (a number) or a string.")
273 (obj)
274 register Lisp_Object obj;
276 if (XTYPE (obj) == Lisp_Int || XTYPE (obj) == Lisp_String)
277 return Qt;
278 return Qnil;
281 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is a number.")
282 (obj)
283 Lisp_Object obj;
285 if (XTYPE (obj) == Lisp_Int)
286 return Qt;
287 return Qnil;
290 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
291 "T if OBJECT is an integer or a marker (editor pointer).")
292 (obj)
293 register Lisp_Object obj;
295 if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int)
296 return Qt;
297 return Qnil;
300 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.")
301 (obj)
302 Lisp_Object obj;
304 if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0)
305 return Qt;
306 return Qnil;
309 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
310 "T if OBJECT is a number (floating point or integer).")
311 (obj)
312 Lisp_Object obj;
314 if (NUMBERP (obj))
315 return Qt;
316 else
317 return Qnil;
320 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
321 Snumber_or_marker_p, 1, 1, 0,
322 "T if OBJECT is a number or a marker.")
323 (obj)
324 Lisp_Object obj;
326 if (NUMBERP (obj)
327 || XTYPE (obj) == Lisp_Marker)
328 return Qt;
329 return Qnil;
332 #ifdef LISP_FLOAT_TYPE
333 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
334 "T if OBJECT is a floating point number.")
335 (obj)
336 Lisp_Object obj;
338 if (XTYPE (obj) == Lisp_Float)
339 return Qt;
340 return Qnil;
342 #endif /* LISP_FLOAT_TYPE */
344 /* Extract and set components of lists */
346 DEFUN ("car", Fcar, Scar, 1, 1, 0,
347 "Return the car of CONSCELL. If arg is nil, return nil.\n\
348 Error if arg is not nil and not a cons cell. See also `car-safe'.")
349 (list)
350 register Lisp_Object list;
352 while (1)
354 if (XTYPE (list) == Lisp_Cons)
355 return XCONS (list)->car;
356 else if (EQ (list, Qnil))
357 return Qnil;
358 else
359 list = wrong_type_argument (Qlistp, list);
363 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
364 "Return the car of OBJECT if it is a cons cell, or else nil.")
365 (object)
366 Lisp_Object object;
368 if (XTYPE (object) == Lisp_Cons)
369 return XCONS (object)->car;
370 else
371 return Qnil;
374 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
375 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\
376 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
378 (list)
379 register Lisp_Object list;
381 while (1)
383 if (XTYPE (list) == Lisp_Cons)
384 return XCONS (list)->cdr;
385 else if (EQ (list, Qnil))
386 return Qnil;
387 else
388 list = wrong_type_argument (Qlistp, list);
392 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
393 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
394 (object)
395 Lisp_Object object;
397 if (XTYPE (object) == Lisp_Cons)
398 return XCONS (object)->cdr;
399 else
400 return Qnil;
403 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
404 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
405 (cell, newcar)
406 register Lisp_Object cell, newcar;
408 if (XTYPE (cell) != Lisp_Cons)
409 cell = wrong_type_argument (Qconsp, cell);
411 CHECK_IMPURE (cell);
412 XCONS (cell)->car = newcar;
413 return newcar;
416 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
417 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
418 (cell, newcdr)
419 register Lisp_Object cell, newcdr;
421 if (XTYPE (cell) != Lisp_Cons)
422 cell = wrong_type_argument (Qconsp, cell);
424 CHECK_IMPURE (cell);
425 XCONS (cell)->cdr = newcdr;
426 return newcdr;
429 /* Extract and set components of symbols */
431 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
432 (sym)
433 register Lisp_Object sym;
435 Lisp_Object valcontents;
436 CHECK_SYMBOL (sym, 0);
438 valcontents = XSYMBOL (sym)->value;
440 #ifdef SWITCH_ENUM_BUG
441 switch ((int) XTYPE (valcontents))
442 #else
443 switch (XTYPE (valcontents))
444 #endif
446 case Lisp_Buffer_Local_Value:
447 case Lisp_Some_Buffer_Local_Value:
448 valcontents = swap_in_symval_forwarding (sym, valcontents);
451 return (XTYPE (valcontents) == Lisp_Void || EQ (valcontents, Qunbound)
452 ? Qnil : Qt);
455 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
456 (sym)
457 register Lisp_Object sym;
459 CHECK_SYMBOL (sym, 0);
460 return (XTYPE (XSYMBOL (sym)->function) == Lisp_Void
461 || EQ (XSYMBOL (sym)->function, Qunbound))
462 ? Qnil : Qt;
465 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
466 (sym)
467 register Lisp_Object sym;
469 CHECK_SYMBOL (sym, 0);
470 if (NILP (sym) || EQ (sym, Qt))
471 return Fsignal (Qsetting_constant, Fcons (sym, Qnil));
472 Fset (sym, Qunbound);
473 return sym;
476 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
477 (sym)
478 register Lisp_Object sym;
480 CHECK_SYMBOL (sym, 0);
481 XSYMBOL (sym)->function = Qunbound;
482 return sym;
485 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
486 "Return SYMBOL's function definition. Error if that is void.")
487 (symbol)
488 register Lisp_Object symbol;
490 CHECK_SYMBOL (symbol, 0);
491 if (EQ (XSYMBOL (symbol)->function, Qunbound))
492 return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
493 return XSYMBOL (symbol)->function;
496 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
497 (sym)
498 register Lisp_Object sym;
500 CHECK_SYMBOL (sym, 0);
501 return XSYMBOL (sym)->plist;
504 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
505 (sym)
506 register Lisp_Object sym;
508 register Lisp_Object name;
510 CHECK_SYMBOL (sym, 0);
511 XSET (name, Lisp_String, XSYMBOL (sym)->name);
512 return name;
515 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
516 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
517 (sym, newdef)
518 register Lisp_Object sym, newdef;
520 CHECK_SYMBOL (sym, 0);
521 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
522 Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
523 Vautoload_queue);
524 XSYMBOL (sym)->function = newdef;
525 return newdef;
528 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
529 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
530 Associates the function with the current load file, if any.")
531 (sym, newdef)
532 register Lisp_Object sym, newdef;
534 CHECK_SYMBOL (sym, 0);
535 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
536 Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
537 Vautoload_queue);
538 XSYMBOL (sym)->function = newdef;
539 LOADHIST_ATTACH (sym);
540 return newdef;
543 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
544 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
545 (sym, newplist)
546 register Lisp_Object sym, newplist;
548 CHECK_SYMBOL (sym, 0);
549 XSYMBOL (sym)->plist = newplist;
550 return newplist;
554 /* Getting and setting values of symbols */
556 /* Given the raw contents of a symbol value cell,
557 return the Lisp value of the symbol.
558 This does not handle buffer-local variables; use
559 swap_in_symval_forwarding for that. */
561 Lisp_Object
562 do_symval_forwarding (valcontents)
563 register Lisp_Object valcontents;
565 register Lisp_Object val;
566 #ifdef SWITCH_ENUM_BUG
567 switch ((int) XTYPE (valcontents))
568 #else
569 switch (XTYPE (valcontents))
570 #endif
572 case Lisp_Intfwd:
573 XSET (val, Lisp_Int, *XINTPTR (valcontents));
574 return val;
576 case Lisp_Boolfwd:
577 if (*XINTPTR (valcontents))
578 return Qt;
579 return Qnil;
581 case Lisp_Objfwd:
582 return *XOBJFWD (valcontents);
584 case Lisp_Buffer_Objfwd:
585 return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
587 return valcontents;
590 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
591 of SYM. If SYM is buffer-local, VALCONTENTS should be the
592 buffer-independent contents of the value cell: forwarded just one
593 step past the buffer-localness. */
595 void
596 store_symval_forwarding (sym, valcontents, newval)
597 Lisp_Object sym;
598 register Lisp_Object valcontents, newval;
600 #ifdef SWITCH_ENUM_BUG
601 switch ((int) XTYPE (valcontents))
602 #else
603 switch (XTYPE (valcontents))
604 #endif
606 case Lisp_Intfwd:
607 CHECK_NUMBER (newval, 1);
608 *XINTPTR (valcontents) = XINT (newval);
609 break;
611 case Lisp_Boolfwd:
612 *XINTPTR (valcontents) = NILP(newval) ? 0 : 1;
613 break;
615 case Lisp_Objfwd:
616 *XOBJFWD (valcontents) = newval;
617 break;
619 case Lisp_Buffer_Objfwd:
621 unsigned int offset = XUINT (valcontents);
622 Lisp_Object type =
623 *(Lisp_Object *)(offset + (char *)&buffer_local_types);
625 if (! NILP (type) && ! NILP (newval)
626 && XTYPE (newval) != XINT (type))
627 buffer_slot_type_mismatch (valcontents, newval);
629 *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer)
630 = newval;
631 break;
634 default:
635 valcontents = XSYMBOL (sym)->value;
636 if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
637 || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
638 XCONS (XSYMBOL (sym)->value)->car = newval;
639 else
640 XSYMBOL (sym)->value = newval;
644 /* Set up the buffer-local symbol SYM for validity in the current
645 buffer. VALCONTENTS is the contents of its value cell.
646 Return the value forwarded one step past the buffer-local indicator. */
648 static Lisp_Object
649 swap_in_symval_forwarding (sym, valcontents)
650 Lisp_Object sym, valcontents;
652 /* valcontents is a list
653 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
655 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
656 local_var_alist, that being the element whose car is this
657 variable. Or it can be a pointer to the
658 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
659 an element in its alist for this variable.
661 If the current buffer is not BUFFER, we store the current
662 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
663 appropriate alist element for the buffer now current and set up
664 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
665 element, and store into BUFFER.
667 Note that REALVALUE can be a forwarding pointer. */
669 register Lisp_Object tem1;
670 tem1 = XCONS (XCONS (valcontents)->cdr)->car;
672 if (NILP (tem1) || current_buffer != XBUFFER (tem1))
674 tem1 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
675 Fsetcdr (tem1, do_symval_forwarding (XCONS (valcontents)->car));
676 tem1 = assq_no_quit (sym, current_buffer->local_var_alist);
677 if (NILP (tem1))
678 tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
679 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
680 XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer);
681 store_symval_forwarding (sym, XCONS (valcontents)->car, Fcdr (tem1));
683 return XCONS (valcontents)->car;
686 /* Find the value of a symbol, returning Qunbound if it's not bound.
687 This is helpful for code which just wants to get a variable's value
688 if it has one, without signalling an error.
689 Note that it must not be possible to quit
690 within this function. Great care is required for this. */
692 Lisp_Object
693 find_symbol_value (sym)
694 Lisp_Object sym;
696 register Lisp_Object valcontents, tem1;
697 register Lisp_Object val;
698 CHECK_SYMBOL (sym, 0);
699 valcontents = XSYMBOL (sym)->value;
701 retry:
702 #ifdef SWITCH_ENUM_BUG
703 switch ((int) XTYPE (valcontents))
704 #else
705 switch (XTYPE (valcontents))
706 #endif
708 case Lisp_Buffer_Local_Value:
709 case Lisp_Some_Buffer_Local_Value:
710 valcontents = swap_in_symval_forwarding (sym, valcontents);
711 goto retry;
713 case Lisp_Intfwd:
714 XSET (val, Lisp_Int, *XINTPTR (valcontents));
715 return val;
717 case Lisp_Boolfwd:
718 if (*XINTPTR (valcontents))
719 return Qt;
720 return Qnil;
722 case Lisp_Objfwd:
723 return *XOBJFWD (valcontents);
725 case Lisp_Buffer_Objfwd:
726 return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
728 case Lisp_Void:
729 return Qunbound;
732 return valcontents;
735 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
736 "Return SYMBOL's value. Error if that is void.")
737 (sym)
738 Lisp_Object sym;
740 Lisp_Object val = find_symbol_value (sym);
742 if (EQ (val, Qunbound))
743 return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
744 else
745 return val;
748 DEFUN ("set", Fset, Sset, 2, 2, 0,
749 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
750 (sym, newval)
751 register Lisp_Object sym, newval;
753 int voide = (XTYPE (newval) == Lisp_Void || EQ (newval, Qunbound));
755 #ifndef RTPC_REGISTER_BUG
756 register Lisp_Object valcontents, tem1, current_alist_element;
757 #else /* RTPC_REGISTER_BUG */
758 register Lisp_Object tem1;
759 Lisp_Object valcontents, current_alist_element;
760 #endif /* RTPC_REGISTER_BUG */
762 CHECK_SYMBOL (sym, 0);
763 if (NILP (sym) || EQ (sym, Qt))
764 return Fsignal (Qsetting_constant, Fcons (sym, Qnil));
765 valcontents = XSYMBOL (sym)->value;
767 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
769 register int idx = XUINT (valcontents);
770 register int mask = *(int *)(idx + (char *) &buffer_local_flags);
771 if (mask > 0)
772 current_buffer->local_var_flags |= mask;
775 else if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
776 || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
778 /* valcontents is actually a pointer to a cons heading something like:
779 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
781 BUFFER is the last buffer for which this symbol's value was
782 made up to date.
784 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
785 local_var_alist, that being the element whose car is this
786 variable. Or it can be a pointer to the
787 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
788 have an element in its alist for this variable (that is, if
789 BUFFER sees the default value of this variable).
791 If we want to examine or set the value and BUFFER is current,
792 we just examine or set REALVALUE. If BUFFER is not current, we
793 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
794 then find the appropriate alist element for the buffer now
795 current and set up CURRENT-ALIST-ELEMENT. Then we set
796 REALVALUE out of that element, and store into BUFFER.
798 If we are setting the variable and the current buffer does
799 not have an alist entry for this variable, an alist entry is
800 created.
802 Note that REALVALUE can be a forwarding pointer. Each time
803 it is examined or set, forwarding must be done. */
805 /* What value are we caching right now? */
806 current_alist_element =
807 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
809 /* If the current buffer is not the buffer whose binding is
810 currently cached, or if it's a Lisp_Buffer_Local_Value and
811 we're looking at the default value, the cache is invalid; we
812 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
813 if ((current_buffer
814 != XBUFFER (XCONS (XCONS (valcontents)->cdr)->car))
815 || (XTYPE (valcontents) == Lisp_Buffer_Local_Value
816 && EQ (XCONS (current_alist_element)->car,
817 current_alist_element)))
819 /* Write out the cached value for the old buffer; copy it
820 back to its alist element. This works if the current
821 buffer only sees the default value, too. */
822 Fsetcdr (current_alist_element,
823 do_symval_forwarding (XCONS (valcontents)->car));
825 /* Find the new value for CURRENT-ALIST-ELEMENT. */
826 tem1 = Fassq (sym, current_buffer->local_var_alist);
827 if (NILP (tem1))
829 /* This buffer still sees the default value. */
831 /* If the variable is a Lisp_Some_Buffer_Local_Value,
832 make CURRENT-ALIST-ELEMENT point to itself,
833 indicating that we're seeing the default value. */
834 if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
835 tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
837 /* If it's a Lisp_Buffer_Local_Value, give this buffer a
838 new assoc for a local value and set
839 CURRENT-ALIST-ELEMENT to point to that. */
840 else
842 tem1 = Fcons (sym, Fcdr (current_alist_element));
843 current_buffer->local_var_alist =
844 Fcons (tem1, current_buffer->local_var_alist);
847 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
848 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
850 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
851 XSET (XCONS (XCONS (valcontents)->cdr)->car,
852 Lisp_Buffer, current_buffer);
854 valcontents = XCONS (valcontents)->car;
857 /* If storing void (making the symbol void), forward only through
858 buffer-local indicator, not through Lisp_Objfwd, etc. */
859 if (voide)
860 store_symval_forwarding (sym, Qnil, newval);
861 else
862 store_symval_forwarding (sym, valcontents, newval);
864 return newval;
867 /* Access or set a buffer-local symbol's default value. */
869 /* Return the default value of SYM, but don't check for voidness.
870 Return Qunbound or a Lisp_Void object if it is void. */
872 Lisp_Object
873 default_value (sym)
874 Lisp_Object sym;
876 register Lisp_Object valcontents;
878 CHECK_SYMBOL (sym, 0);
879 valcontents = XSYMBOL (sym)->value;
881 /* For a built-in buffer-local variable, get the default value
882 rather than letting do_symval_forwarding get the current value. */
883 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
885 register int idx = XUINT (valcontents);
887 if (*(int *) (idx + (char *) &buffer_local_flags) != 0)
888 return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
891 /* Handle user-created local variables. */
892 if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
893 || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
895 /* If var is set up for a buffer that lacks a local value for it,
896 the current value is nominally the default value.
897 But the current value slot may be more up to date, since
898 ordinary setq stores just that slot. So use that. */
899 Lisp_Object current_alist_element, alist_element_car;
900 current_alist_element
901 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
902 alist_element_car = XCONS (current_alist_element)->car;
903 if (EQ (alist_element_car, current_alist_element))
904 return do_symval_forwarding (XCONS (valcontents)->car);
905 else
906 return XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr;
908 /* For other variables, get the current value. */
909 return do_symval_forwarding (valcontents);
912 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
913 "Return T if SYMBOL has a non-void default value.\n\
914 This is the value that is seen in buffers that do not have their own values\n\
915 for this variable.")
916 (sym)
917 Lisp_Object sym;
919 register Lisp_Object value;
921 value = default_value (sym);
922 return (XTYPE (value) == Lisp_Void || EQ (value, Qunbound)
923 ? Qnil : Qt);
926 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
927 "Return SYMBOL's default value.\n\
928 This is the value that is seen in buffers that do not have their own values\n\
929 for this variable. The default value is meaningful for variables with\n\
930 local bindings in certain buffers.")
931 (sym)
932 Lisp_Object sym;
934 register Lisp_Object value;
936 value = default_value (sym);
937 if (XTYPE (value) == Lisp_Void || EQ (value, Qunbound))
938 return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
939 return value;
942 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
943 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
944 The default value is seen in buffers that do not have their own values\n\
945 for this variable.")
946 (sym, value)
947 Lisp_Object sym, value;
949 register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
951 CHECK_SYMBOL (sym, 0);
952 valcontents = XSYMBOL (sym)->value;
954 /* Handle variables like case-fold-search that have special slots
955 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
956 variables. */
957 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
959 register int idx = XUINT (valcontents);
960 #ifndef RTPC_REGISTER_BUG
961 register struct buffer *b;
962 #else
963 struct buffer *b;
964 #endif
965 register int mask = *(int *) (idx + (char *) &buffer_local_flags);
967 if (mask > 0)
969 *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
970 for (b = all_buffers; b; b = b->next)
971 if (!(b->local_var_flags & mask))
972 *(Lisp_Object *)(idx + (char *) b) = value;
974 return value;
977 if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
978 XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
979 return Fset (sym, value);
981 /* Store new value into the DEFAULT-VALUE slot */
982 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr = value;
984 /* If that slot is current, we must set the REALVALUE slot too */
985 current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
986 alist_element_buffer = Fcar (current_alist_element);
987 if (EQ (alist_element_buffer, current_alist_element))
988 store_symval_forwarding (sym, XCONS (valcontents)->car, value);
990 return value;
993 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
995 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
996 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\
997 not have their own values for this variable.")
998 (args)
999 Lisp_Object args;
1001 register Lisp_Object args_left;
1002 register Lisp_Object val, sym;
1003 struct gcpro gcpro1;
1005 if (NILP (args))
1006 return Qnil;
1008 args_left = args;
1009 GCPRO1 (args);
1013 val = Feval (Fcar (Fcdr (args_left)));
1014 sym = Fcar (args_left);
1015 Fset_default (sym, val);
1016 args_left = Fcdr (Fcdr (args_left));
1018 while (!NILP (args_left));
1020 UNGCPRO;
1021 return val;
1024 /* Lisp functions for creating and removing buffer-local variables. */
1026 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1027 1, 1, "vMake Variable Buffer Local: ",
1028 "Make VARIABLE have a separate value for each buffer.\n\
1029 At any time, the value for the current buffer is in effect.\n\
1030 There is also a default value which is seen in any buffer which has not yet\n\
1031 set its own value.\n\
1032 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1033 for the current buffer if it was previously using the default value.\n\
1034 The function `default-value' gets the default value and `set-default' sets it.")
1035 (sym)
1036 register Lisp_Object sym;
1038 register Lisp_Object tem, valcontents;
1040 CHECK_SYMBOL (sym, 0);
1042 if (EQ (sym, Qnil) || EQ (sym, Qt))
1043 error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
1045 valcontents = XSYMBOL (sym)->value;
1046 if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) ||
1047 (XTYPE (valcontents) == Lisp_Buffer_Objfwd))
1048 return sym;
1049 if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
1051 XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
1052 return sym;
1054 if (EQ (valcontents, Qunbound))
1055 XSYMBOL (sym)->value = Qnil;
1056 tem = Fcons (Qnil, Fsymbol_value (sym));
1057 XCONS (tem)->car = tem;
1058 XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Fcurrent_buffer (), tem));
1059 XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
1060 return sym;
1063 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1064 1, 1, "vMake Local Variable: ",
1065 "Make VARIABLE have a separate value in the current buffer.\n\
1066 Other buffers will continue to share a common default value.\n\
1067 See also `make-variable-buffer-local'.\n\n\
1068 If the variable is already arranged to become local when set,\n\
1069 this function causes a local value to exist for this buffer,\n\
1070 just as if the variable were set.")
1071 (sym)
1072 register Lisp_Object sym;
1074 register Lisp_Object tem, valcontents;
1076 CHECK_SYMBOL (sym, 0);
1078 if (EQ (sym, Qnil) || EQ (sym, Qt))
1079 error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
1081 valcontents = XSYMBOL (sym)->value;
1082 if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
1083 || XTYPE (valcontents) == Lisp_Buffer_Objfwd)
1085 tem = Fboundp (sym);
1087 /* Make sure the symbol has a local value in this particular buffer,
1088 by setting it to the same value it already has. */
1089 Fset (sym, (EQ (tem, Qt) ? Fsymbol_value (sym) : Qunbound));
1090 return sym;
1092 /* Make sure sym is set up to hold per-buffer values */
1093 if (XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
1095 if (EQ (valcontents, Qunbound))
1096 XSYMBOL (sym)->value = Qnil;
1097 tem = Fcons (Qnil, do_symval_forwarding (valcontents));
1098 XCONS (tem)->car = tem;
1099 XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Qnil, tem));
1100 XSETTYPE (XSYMBOL (sym)->value, Lisp_Some_Buffer_Local_Value);
1102 /* Make sure this buffer has its own value of sym */
1103 tem = Fassq (sym, current_buffer->local_var_alist);
1104 if (NILP (tem))
1106 current_buffer->local_var_alist
1107 = Fcons (Fcons (sym, XCONS (XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->cdr)->cdr),
1108 current_buffer->local_var_alist);
1110 /* Make sure symbol does not think it is set up for this buffer;
1111 force it to look once again for this buffer's value */
1113 /* This local variable avoids "expression too complex" on IBM RT. */
1114 Lisp_Object xs;
1116 xs = XSYMBOL (sym)->value;
1117 if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car))
1118 XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil;
1122 /* If the symbol forwards into a C variable, then swap in the
1123 variable for this buffer immediately. If C code modifies the
1124 variable before we swap in, then that new value will clobber the
1125 default value the next time we swap. */
1126 valcontents = XCONS (XSYMBOL (sym)->value)->car;
1127 if (XTYPE (valcontents) == Lisp_Intfwd
1128 || XTYPE (valcontents) == Lisp_Boolfwd
1129 || XTYPE (valcontents) == Lisp_Objfwd)
1130 swap_in_symval_forwarding (sym, XSYMBOL (sym)->value);
1132 return sym;
1135 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1136 1, 1, "vKill Local Variable: ",
1137 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1138 From now on the default value will apply in this buffer.")
1139 (sym)
1140 register Lisp_Object sym;
1142 register Lisp_Object tem, valcontents;
1144 CHECK_SYMBOL (sym, 0);
1146 valcontents = XSYMBOL (sym)->value;
1148 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
1150 register int idx = XUINT (valcontents);
1151 register int mask = *(int *) (idx + (char *) &buffer_local_flags);
1153 if (mask > 0)
1155 *(Lisp_Object *)(idx + (char *) current_buffer)
1156 = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1157 current_buffer->local_var_flags &= ~mask;
1159 return sym;
1162 if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
1163 XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
1164 return sym;
1166 /* Get rid of this buffer's alist element, if any */
1168 tem = Fassq (sym, current_buffer->local_var_alist);
1169 if (!NILP (tem))
1170 current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist);
1172 /* Make sure symbol does not think it is set up for this buffer;
1173 force it to look once again for this buffer's value */
1175 Lisp_Object sv;
1176 sv = XSYMBOL (sym)->value;
1177 if (current_buffer == XBUFFER (XCONS (XCONS (sv)->cdr)->car))
1178 XCONS (XCONS (sv)->cdr)->car = Qnil;
1181 return sym;
1184 /* Find the function at the end of a chain of symbol function indirections. */
1186 /* If OBJECT is a symbol, find the end of its function chain and
1187 return the value found there. If OBJECT is not a symbol, just
1188 return it. If there is a cycle in the function chain, signal a
1189 cyclic-function-indirection error.
1191 This is like Findirect_function, except that it doesn't signal an
1192 error if the chain ends up unbound. */
1193 Lisp_Object
1194 indirect_function (object)
1195 register Lisp_Object object;
1197 Lisp_Object tortise, hare;
1199 hare = tortise = object;
1201 for (;;)
1203 if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
1204 break;
1205 hare = XSYMBOL (hare)->function;
1206 if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
1207 break;
1208 hare = XSYMBOL (hare)->function;
1210 tortise = XSYMBOL (tortise)->function;
1212 if (EQ (hare, tortise))
1213 Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
1216 return hare;
1219 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
1220 "Return the function at the end of OBJECT's function chain.\n\
1221 If OBJECT is a symbol, follow all function indirections and return the final\n\
1222 function binding.\n\
1223 If OBJECT is not a symbol, just return it.\n\
1224 Signal a void-function error if the final symbol is unbound.\n\
1225 Signal a cyclic-function-indirection error if there is a loop in the\n\
1226 function chain of symbols.")
1227 (object)
1228 register Lisp_Object object;
1230 Lisp_Object result;
1232 result = indirect_function (object);
1234 if (EQ (result, Qunbound))
1235 return Fsignal (Qvoid_function, Fcons (object, Qnil));
1236 return result;
1239 /* Extract and set vector and string elements */
1241 DEFUN ("aref", Faref, Saref, 2, 2, 0,
1242 "Return the element of ARRAY at index INDEX.\n\
1243 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.")
1244 (array, idx)
1245 register Lisp_Object array;
1246 Lisp_Object idx;
1248 register int idxval;
1250 CHECK_NUMBER (idx, 1);
1251 idxval = XINT (idx);
1252 if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String
1253 && XTYPE (array) != Lisp_Compiled)
1254 array = wrong_type_argument (Qarrayp, array);
1255 if (idxval < 0 || idxval >= XVECTOR (array)->size)
1256 args_out_of_range (array, idx);
1257 if (XTYPE (array) == Lisp_String)
1259 Lisp_Object val;
1260 XFASTINT (val) = (unsigned char) XSTRING (array)->data[idxval];
1261 return val;
1263 else
1264 return XVECTOR (array)->contents[idxval];
1267 DEFUN ("aset", Faset, Saset, 3, 3, 0,
1268 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1269 ARRAY may be a vector or a string. INDEX starts at 0.")
1270 (array, idx, newelt)
1271 register Lisp_Object array;
1272 Lisp_Object idx, newelt;
1274 register int idxval;
1276 CHECK_NUMBER (idx, 1);
1277 idxval = XINT (idx);
1278 if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String)
1279 array = wrong_type_argument (Qarrayp, array);
1280 if (idxval < 0 || idxval >= XVECTOR (array)->size)
1281 args_out_of_range (array, idx);
1282 CHECK_IMPURE (array);
1284 if (XTYPE (array) == Lisp_Vector)
1285 XVECTOR (array)->contents[idxval] = newelt;
1286 else
1288 CHECK_NUMBER (newelt, 2);
1289 XSTRING (array)->data[idxval] = XINT (newelt);
1292 return newelt;
1295 Lisp_Object
1296 Farray_length (array)
1297 register Lisp_Object array;
1299 register Lisp_Object size;
1300 if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String
1301 && XTYPE (array) != Lisp_Compiled)
1302 array = wrong_type_argument (Qarrayp, array);
1303 XFASTINT (size) = XVECTOR (array)->size;
1304 return size;
1307 /* Arithmetic functions */
1309 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
1311 Lisp_Object
1312 arithcompare (num1, num2, comparison)
1313 Lisp_Object num1, num2;
1314 enum comparison comparison;
1316 double f1, f2;
1317 int floatp = 0;
1319 #ifdef LISP_FLOAT_TYPE
1320 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
1321 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
1323 if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float)
1325 floatp = 1;
1326 f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1);
1327 f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2);
1329 #else
1330 CHECK_NUMBER_COERCE_MARKER (num1, 0);
1331 CHECK_NUMBER_COERCE_MARKER (num2, 0);
1332 #endif /* LISP_FLOAT_TYPE */
1334 switch (comparison)
1336 case equal:
1337 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
1338 return Qt;
1339 return Qnil;
1341 case notequal:
1342 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
1343 return Qt;
1344 return Qnil;
1346 case less:
1347 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
1348 return Qt;
1349 return Qnil;
1351 case less_or_equal:
1352 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
1353 return Qt;
1354 return Qnil;
1356 case grtr:
1357 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
1358 return Qt;
1359 return Qnil;
1361 case grtr_or_equal:
1362 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
1363 return Qt;
1364 return Qnil;
1366 default:
1367 abort ();
1371 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
1372 "T if two args, both numbers or markers, are equal.")
1373 (num1, num2)
1374 register Lisp_Object num1, num2;
1376 return arithcompare (num1, num2, equal);
1379 DEFUN ("<", Flss, Slss, 2, 2, 0,
1380 "T if first arg is less than second arg. Both must be numbers or markers.")
1381 (num1, num2)
1382 register Lisp_Object num1, num2;
1384 return arithcompare (num1, num2, less);
1387 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
1388 "T if first arg is greater than second arg. Both must be numbers or markers.")
1389 (num1, num2)
1390 register Lisp_Object num1, num2;
1392 return arithcompare (num1, num2, grtr);
1395 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
1396 "T if first arg is less than or equal to second arg.\n\
1397 Both must be numbers or markers.")
1398 (num1, num2)
1399 register Lisp_Object num1, num2;
1401 return arithcompare (num1, num2, less_or_equal);
1404 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
1405 "T if first arg is greater than or equal to second arg.\n\
1406 Both must be numbers or markers.")
1407 (num1, num2)
1408 register Lisp_Object num1, num2;
1410 return arithcompare (num1, num2, grtr_or_equal);
1413 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
1414 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1415 (num1, num2)
1416 register Lisp_Object num1, num2;
1418 return arithcompare (num1, num2, notequal);
1421 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
1422 (num)
1423 register Lisp_Object num;
1425 #ifdef LISP_FLOAT_TYPE
1426 CHECK_NUMBER_OR_FLOAT (num, 0);
1428 if (XTYPE(num) == Lisp_Float)
1430 if (XFLOAT(num)->data == 0.0)
1431 return Qt;
1432 return Qnil;
1434 #else
1435 CHECK_NUMBER (num, 0);
1436 #endif /* LISP_FLOAT_TYPE */
1438 if (!XINT (num))
1439 return Qt;
1440 return Qnil;
1443 /* Convert between 32-bit values and pairs of lispy 24-bit values. */
1445 Lisp_Object
1446 long_to_cons (i)
1447 unsigned long i;
1449 unsigned int top = i >> 16;
1450 unsigned int bot = i & 0xFFFF;
1451 if (top == 0)
1452 return make_number (bot);
1453 if (top == 0xFFFF)
1454 return Fcons (make_number (-1), make_number (bot));
1455 return Fcons (make_number (top), make_number (bot));
1458 unsigned long
1459 cons_to_long (c)
1460 Lisp_Object c;
1462 int top, bot;
1463 if (INTEGERP (c))
1464 return XINT (c);
1465 top = XCONS (c)->car;
1466 bot = XCONS (c)->cdr;
1467 if (CONSP (bot))
1468 bot = XCONS (bot)->car;
1469 return ((XINT (top) << 16) | XINT (bot));
1472 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
1473 "Convert NUM to a string by printing it in decimal.\n\
1474 Uses a minus sign if negative.\n\
1475 NUM may be an integer or a floating point number.")
1476 (num)
1477 Lisp_Object num;
1479 char buffer[20];
1481 #ifndef LISP_FLOAT_TYPE
1482 CHECK_NUMBER (num, 0);
1483 #else
1484 CHECK_NUMBER_OR_FLOAT (num, 0);
1486 if (XTYPE(num) == Lisp_Float)
1488 char pigbuf[350]; /* see comments in float_to_string */
1490 float_to_string (pigbuf, XFLOAT(num)->data);
1491 return build_string (pigbuf);
1493 #endif /* LISP_FLOAT_TYPE */
1495 sprintf (buffer, "%d", XINT (num));
1496 return build_string (buffer);
1499 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
1500 "Convert STRING to a number by parsing it as a decimal number.\n\
1501 This parses both integers and floating point numbers.")
1502 (str)
1503 register Lisp_Object str;
1505 unsigned char *p;
1507 CHECK_STRING (str, 0);
1509 p = XSTRING (str)->data;
1511 /* Skip any whitespace at the front of the number. Some versions of
1512 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1513 while (*p == ' ' || *p == '\t')
1514 p++;
1516 #ifdef LISP_FLOAT_TYPE
1517 if (isfloat_string (p))
1518 return make_float (atof (p));
1519 #endif /* LISP_FLOAT_TYPE */
1521 return make_number (atoi (p));
1524 enum arithop
1525 { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
1527 extern Lisp_Object float_arith_driver ();
1529 Lisp_Object
1530 arith_driver
1531 (code, nargs, args)
1532 enum arithop code;
1533 int nargs;
1534 register Lisp_Object *args;
1536 register Lisp_Object val;
1537 register int argnum;
1538 register int accum;
1539 register int next;
1541 #ifdef SWITCH_ENUM_BUG
1542 switch ((int) code)
1543 #else
1544 switch (code)
1545 #endif
1547 case Alogior:
1548 case Alogxor:
1549 case Aadd:
1550 case Asub:
1551 accum = 0; break;
1552 case Amult:
1553 accum = 1; break;
1554 case Alogand:
1555 accum = -1; break;
1558 for (argnum = 0; argnum < nargs; argnum++)
1560 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1561 #ifdef LISP_FLOAT_TYPE
1562 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
1564 if (XTYPE (val) == Lisp_Float) /* time to do serious math */
1565 return (float_arith_driver ((double) accum, argnum, code,
1566 nargs, args));
1567 #else
1568 CHECK_NUMBER_COERCE_MARKER (val, argnum);
1569 #endif /* LISP_FLOAT_TYPE */
1570 args[argnum] = val; /* runs into a compiler bug. */
1571 next = XINT (args[argnum]);
1572 #ifdef SWITCH_ENUM_BUG
1573 switch ((int) code)
1574 #else
1575 switch (code)
1576 #endif
1578 case Aadd: accum += next; break;
1579 case Asub:
1580 if (!argnum && nargs != 1)
1581 next = - next;
1582 accum -= next;
1583 break;
1584 case Amult: accum *= next; break;
1585 case Adiv:
1586 if (!argnum) accum = next;
1587 else accum /= next;
1588 break;
1589 case Alogand: accum &= next; break;
1590 case Alogior: accum |= next; break;
1591 case Alogxor: accum ^= next; break;
1592 case Amax: if (!argnum || next > accum) accum = next; break;
1593 case Amin: if (!argnum || next < accum) accum = next; break;
1597 XSET (val, Lisp_Int, accum);
1598 return val;
1601 #ifdef LISP_FLOAT_TYPE
1602 Lisp_Object
1603 float_arith_driver (accum, argnum, code, nargs, args)
1604 double accum;
1605 register int argnum;
1606 enum arithop code;
1607 int nargs;
1608 register Lisp_Object *args;
1610 register Lisp_Object val;
1611 double next;
1613 for (; argnum < nargs; argnum++)
1615 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1616 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
1618 if (XTYPE (val) == Lisp_Float)
1620 next = XFLOAT (val)->data;
1622 else
1624 args[argnum] = val; /* runs into a compiler bug. */
1625 next = XINT (args[argnum]);
1627 #ifdef SWITCH_ENUM_BUG
1628 switch ((int) code)
1629 #else
1630 switch (code)
1631 #endif
1633 case Aadd:
1634 accum += next;
1635 break;
1636 case Asub:
1637 if (!argnum && nargs != 1)
1638 next = - next;
1639 accum -= next;
1640 break;
1641 case Amult:
1642 accum *= next;
1643 break;
1644 case Adiv:
1645 if (!argnum)
1646 accum = next;
1647 else
1648 accum /= next;
1649 break;
1650 case Alogand:
1651 case Alogior:
1652 case Alogxor:
1653 return wrong_type_argument (Qinteger_or_marker_p, val);
1654 case Amax:
1655 if (!argnum || next > accum)
1656 accum = next;
1657 break;
1658 case Amin:
1659 if (!argnum || next < accum)
1660 accum = next;
1661 break;
1665 return make_float (accum);
1667 #endif /* LISP_FLOAT_TYPE */
1669 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
1670 "Return sum of any number of arguments, which are numbers or markers.")
1671 (nargs, args)
1672 int nargs;
1673 Lisp_Object *args;
1675 return arith_driver (Aadd, nargs, args);
1678 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
1679 "Negate number or subtract numbers or markers.\n\
1680 With one arg, negates it. With more than one arg,\n\
1681 subtracts all but the first from the first.")
1682 (nargs, args)
1683 int nargs;
1684 Lisp_Object *args;
1686 return arith_driver (Asub, nargs, args);
1689 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
1690 "Returns product of any number of arguments, which are numbers or markers.")
1691 (nargs, args)
1692 int nargs;
1693 Lisp_Object *args;
1695 return arith_driver (Amult, nargs, args);
1698 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
1699 "Returns first argument divided by all the remaining arguments.\n\
1700 The arguments must be numbers or markers.")
1701 (nargs, args)
1702 int nargs;
1703 Lisp_Object *args;
1705 return arith_driver (Adiv, nargs, args);
1708 DEFUN ("%", Frem, Srem, 2, 2, 0,
1709 "Returns remainder of first arg divided by second.\n\
1710 Both must be numbers or markers.")
1711 (num1, num2)
1712 register Lisp_Object num1, num2;
1714 Lisp_Object val;
1716 #ifdef LISP_FLOAT_TYPE
1717 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
1718 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
1720 if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float)
1722 double f1, f2;
1724 f1 = XTYPE (num1) == Lisp_Float ? XFLOAT (num1)->data : XINT (num1);
1725 f2 = XTYPE (num2) == Lisp_Float ? XFLOAT (num2)->data : XINT (num2);
1726 #if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux)
1727 f1 = fmod (f1, f2);
1728 #else
1729 f1 = drem (f1, f2);
1730 #endif
1731 if (f1 < 0)
1732 f1 += f2;
1733 return (make_float (f1));
1735 #else /* not LISP_FLOAT_TYPE */
1736 CHECK_NUMBER_COERCE_MARKER (num1, 0);
1737 CHECK_NUMBER_COERCE_MARKER (num2, 1);
1738 #endif /* not LISP_FLOAT_TYPE */
1740 XSET (val, Lisp_Int, XINT (num1) % XINT (num2));
1741 return val;
1744 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
1745 "Return largest of all the arguments (which must be numbers or markers).\n\
1746 The value is always a number; markers are converted to numbers.")
1747 (nargs, args)
1748 int nargs;
1749 Lisp_Object *args;
1751 return arith_driver (Amax, nargs, args);
1754 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
1755 "Return smallest of all the arguments (which must be numbers or markers).\n\
1756 The value is always a number; markers are converted to numbers.")
1757 (nargs, args)
1758 int nargs;
1759 Lisp_Object *args;
1761 return arith_driver (Amin, nargs, args);
1764 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
1765 "Return bitwise-and of all the arguments.\n\
1766 Arguments may be integers, or markers converted to integers.")
1767 (nargs, args)
1768 int nargs;
1769 Lisp_Object *args;
1771 return arith_driver (Alogand, nargs, args);
1774 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
1775 "Return bitwise-or of all the arguments.\n\
1776 Arguments may be integers, or markers converted to integers.")
1777 (nargs, args)
1778 int nargs;
1779 Lisp_Object *args;
1781 return arith_driver (Alogior, nargs, args);
1784 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
1785 "Return bitwise-exclusive-or of all the arguments.\n\
1786 Arguments may be integers, or markers converted to integers.")
1787 (nargs, args)
1788 int nargs;
1789 Lisp_Object *args;
1791 return arith_driver (Alogxor, nargs, args);
1794 DEFUN ("ash", Fash, Sash, 2, 2, 0,
1795 "Return VALUE with its bits shifted left by COUNT.\n\
1796 If COUNT is negative, shifting is actually to the right.\n\
1797 In this case, the sign bit is duplicated.")
1798 (num1, num2)
1799 register Lisp_Object num1, num2;
1801 register Lisp_Object val;
1803 CHECK_NUMBER (num1, 0);
1804 CHECK_NUMBER (num2, 1);
1806 if (XINT (num2) > 0)
1807 XSET (val, Lisp_Int, XINT (num1) << XFASTINT (num2));
1808 else
1809 XSET (val, Lisp_Int, XINT (num1) >> -XINT (num2));
1810 return val;
1813 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
1814 "Return VALUE with its bits shifted left by COUNT.\n\
1815 If COUNT is negative, shifting is actually to the right.\n\
1816 In this case, zeros are shifted in on the left.")
1817 (num1, num2)
1818 register Lisp_Object num1, num2;
1820 register Lisp_Object val;
1822 CHECK_NUMBER (num1, 0);
1823 CHECK_NUMBER (num2, 1);
1825 if (XINT (num2) > 0)
1826 XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) << XFASTINT (num2));
1827 else
1828 XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) >> -XINT (num2));
1829 return val;
1832 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
1833 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
1834 Markers are converted to integers.")
1835 (num)
1836 register Lisp_Object num;
1838 #ifdef LISP_FLOAT_TYPE
1839 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0);
1841 if (XTYPE (num) == Lisp_Float)
1842 return (make_float (1.0 + XFLOAT (num)->data));
1843 #else
1844 CHECK_NUMBER_COERCE_MARKER (num, 0);
1845 #endif /* LISP_FLOAT_TYPE */
1847 XSETINT (num, XFASTINT (num) + 1);
1848 return num;
1851 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
1852 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
1853 Markers are converted to integers.")
1854 (num)
1855 register Lisp_Object num;
1857 #ifdef LISP_FLOAT_TYPE
1858 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0);
1860 if (XTYPE (num) == Lisp_Float)
1861 return (make_float (-1.0 + XFLOAT (num)->data));
1862 #else
1863 CHECK_NUMBER_COERCE_MARKER (num, 0);
1864 #endif /* LISP_FLOAT_TYPE */
1866 XSETINT (num, XFASTINT (num) - 1);
1867 return num;
1870 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
1871 "Return the bitwise complement of ARG. ARG must be an integer.")
1872 (num)
1873 register Lisp_Object num;
1875 CHECK_NUMBER (num, 0);
1876 XSETINT (num, ~XFASTINT (num));
1877 return num;
1880 void
1881 syms_of_data ()
1883 Lisp_Object error_tail, arith_tail;
1885 Qquote = intern ("quote");
1886 Qlambda = intern ("lambda");
1887 Qsubr = intern ("subr");
1888 Qerror_conditions = intern ("error-conditions");
1889 Qerror_message = intern ("error-message");
1890 Qtop_level = intern ("top-level");
1892 Qerror = intern ("error");
1893 Qquit = intern ("quit");
1894 Qwrong_type_argument = intern ("wrong-type-argument");
1895 Qargs_out_of_range = intern ("args-out-of-range");
1896 Qvoid_function = intern ("void-function");
1897 Qcyclic_function_indirection = intern ("cyclic-function-indirection");
1898 Qvoid_variable = intern ("void-variable");
1899 Qsetting_constant = intern ("setting-constant");
1900 Qinvalid_read_syntax = intern ("invalid-read-syntax");
1902 Qinvalid_function = intern ("invalid-function");
1903 Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
1904 Qno_catch = intern ("no-catch");
1905 Qend_of_file = intern ("end-of-file");
1906 Qarith_error = intern ("arith-error");
1907 Qbeginning_of_buffer = intern ("beginning-of-buffer");
1908 Qend_of_buffer = intern ("end-of-buffer");
1909 Qbuffer_read_only = intern ("buffer-read-only");
1911 Qlistp = intern ("listp");
1912 Qconsp = intern ("consp");
1913 Qsymbolp = intern ("symbolp");
1914 Qintegerp = intern ("integerp");
1915 Qnatnump = intern ("natnump");
1916 Qstringp = intern ("stringp");
1917 Qarrayp = intern ("arrayp");
1918 Qsequencep = intern ("sequencep");
1919 Qbufferp = intern ("bufferp");
1920 Qvectorp = intern ("vectorp");
1921 Qchar_or_string_p = intern ("char-or-string-p");
1922 Qmarkerp = intern ("markerp");
1923 Qbuffer_or_string_p = intern ("buffer-or-string-p");
1924 Qinteger_or_marker_p = intern ("integer-or-marker-p");
1925 Qboundp = intern ("boundp");
1926 Qfboundp = intern ("fboundp");
1928 #ifdef LISP_FLOAT_TYPE
1929 Qfloatp = intern ("floatp");
1930 Qnumberp = intern ("numberp");
1931 Qnumber_or_marker_p = intern ("number-or-marker-p");
1932 #endif /* LISP_FLOAT_TYPE */
1934 Qcdr = intern ("cdr");
1936 error_tail = Fcons (Qerror, Qnil);
1938 /* ERROR is used as a signaler for random errors for which nothing else is right */
1940 Fput (Qerror, Qerror_conditions,
1941 error_tail);
1942 Fput (Qerror, Qerror_message,
1943 build_string ("error"));
1945 Fput (Qquit, Qerror_conditions,
1946 Fcons (Qquit, Qnil));
1947 Fput (Qquit, Qerror_message,
1948 build_string ("Quit"));
1950 Fput (Qwrong_type_argument, Qerror_conditions,
1951 Fcons (Qwrong_type_argument, error_tail));
1952 Fput (Qwrong_type_argument, Qerror_message,
1953 build_string ("Wrong type argument"));
1955 Fput (Qargs_out_of_range, Qerror_conditions,
1956 Fcons (Qargs_out_of_range, error_tail));
1957 Fput (Qargs_out_of_range, Qerror_message,
1958 build_string ("Args out of range"));
1960 Fput (Qvoid_function, Qerror_conditions,
1961 Fcons (Qvoid_function, error_tail));
1962 Fput (Qvoid_function, Qerror_message,
1963 build_string ("Symbol's function definition is void"));
1965 Fput (Qcyclic_function_indirection, Qerror_conditions,
1966 Fcons (Qcyclic_function_indirection, error_tail));
1967 Fput (Qcyclic_function_indirection, Qerror_message,
1968 build_string ("Symbol's chain of function indirections contains a loop"));
1970 Fput (Qvoid_variable, Qerror_conditions,
1971 Fcons (Qvoid_variable, error_tail));
1972 Fput (Qvoid_variable, Qerror_message,
1973 build_string ("Symbol's value as variable is void"));
1975 Fput (Qsetting_constant, Qerror_conditions,
1976 Fcons (Qsetting_constant, error_tail));
1977 Fput (Qsetting_constant, Qerror_message,
1978 build_string ("Attempt to set a constant symbol"));
1980 Fput (Qinvalid_read_syntax, Qerror_conditions,
1981 Fcons (Qinvalid_read_syntax, error_tail));
1982 Fput (Qinvalid_read_syntax, Qerror_message,
1983 build_string ("Invalid read syntax"));
1985 Fput (Qinvalid_function, Qerror_conditions,
1986 Fcons (Qinvalid_function, error_tail));
1987 Fput (Qinvalid_function, Qerror_message,
1988 build_string ("Invalid function"));
1990 Fput (Qwrong_number_of_arguments, Qerror_conditions,
1991 Fcons (Qwrong_number_of_arguments, error_tail));
1992 Fput (Qwrong_number_of_arguments, Qerror_message,
1993 build_string ("Wrong number of arguments"));
1995 Fput (Qno_catch, Qerror_conditions,
1996 Fcons (Qno_catch, error_tail));
1997 Fput (Qno_catch, Qerror_message,
1998 build_string ("No catch for tag"));
2000 Fput (Qend_of_file, Qerror_conditions,
2001 Fcons (Qend_of_file, error_tail));
2002 Fput (Qend_of_file, Qerror_message,
2003 build_string ("End of file during parsing"));
2005 arith_tail = Fcons (Qarith_error, error_tail);
2006 Fput (Qarith_error, Qerror_conditions,
2007 arith_tail);
2008 Fput (Qarith_error, Qerror_message,
2009 build_string ("Arithmetic error"));
2011 Fput (Qbeginning_of_buffer, Qerror_conditions,
2012 Fcons (Qbeginning_of_buffer, error_tail));
2013 Fput (Qbeginning_of_buffer, Qerror_message,
2014 build_string ("Beginning of buffer"));
2016 Fput (Qend_of_buffer, Qerror_conditions,
2017 Fcons (Qend_of_buffer, error_tail));
2018 Fput (Qend_of_buffer, Qerror_message,
2019 build_string ("End of buffer"));
2021 Fput (Qbuffer_read_only, Qerror_conditions,
2022 Fcons (Qbuffer_read_only, error_tail));
2023 Fput (Qbuffer_read_only, Qerror_message,
2024 build_string ("Buffer is read-only"));
2026 #ifdef LISP_FLOAT_TYPE
2027 Qrange_error = intern ("range-error");
2028 Qdomain_error = intern ("domain-error");
2029 Qsingularity_error = intern ("singularity-error");
2030 Qoverflow_error = intern ("overflow-error");
2031 Qunderflow_error = intern ("underflow-error");
2033 Fput (Qdomain_error, Qerror_conditions,
2034 Fcons (Qdomain_error, arith_tail));
2035 Fput (Qdomain_error, Qerror_message,
2036 build_string ("Arithmetic domain error"));
2038 Fput (Qrange_error, Qerror_conditions,
2039 Fcons (Qrange_error, arith_tail));
2040 Fput (Qrange_error, Qerror_message,
2041 build_string ("Arithmetic range error"));
2043 Fput (Qsingularity_error, Qerror_conditions,
2044 Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
2045 Fput (Qsingularity_error, Qerror_message,
2046 build_string ("Arithmetic singularity error"));
2048 Fput (Qoverflow_error, Qerror_conditions,
2049 Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
2050 Fput (Qoverflow_error, Qerror_message,
2051 build_string ("Arithmetic overflow error"));
2053 Fput (Qunderflow_error, Qerror_conditions,
2054 Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
2055 Fput (Qunderflow_error, Qerror_message,
2056 build_string ("Arithmetic underflow error"));
2058 staticpro (&Qrange_error);
2059 staticpro (&Qdomain_error);
2060 staticpro (&Qsingularity_error);
2061 staticpro (&Qoverflow_error);
2062 staticpro (&Qunderflow_error);
2063 #endif /* LISP_FLOAT_TYPE */
2065 staticpro (&Qnil);
2066 staticpro (&Qt);
2067 staticpro (&Qquote);
2068 staticpro (&Qlambda);
2069 staticpro (&Qsubr);
2070 staticpro (&Qunbound);
2071 staticpro (&Qerror_conditions);
2072 staticpro (&Qerror_message);
2073 staticpro (&Qtop_level);
2075 staticpro (&Qerror);
2076 staticpro (&Qquit);
2077 staticpro (&Qwrong_type_argument);
2078 staticpro (&Qargs_out_of_range);
2079 staticpro (&Qvoid_function);
2080 staticpro (&Qcyclic_function_indirection);
2081 staticpro (&Qvoid_variable);
2082 staticpro (&Qsetting_constant);
2083 staticpro (&Qinvalid_read_syntax);
2084 staticpro (&Qwrong_number_of_arguments);
2085 staticpro (&Qinvalid_function);
2086 staticpro (&Qno_catch);
2087 staticpro (&Qend_of_file);
2088 staticpro (&Qarith_error);
2089 staticpro (&Qbeginning_of_buffer);
2090 staticpro (&Qend_of_buffer);
2091 staticpro (&Qbuffer_read_only);
2093 staticpro (&Qlistp);
2094 staticpro (&Qconsp);
2095 staticpro (&Qsymbolp);
2096 staticpro (&Qintegerp);
2097 staticpro (&Qnatnump);
2098 staticpro (&Qstringp);
2099 staticpro (&Qarrayp);
2100 staticpro (&Qsequencep);
2101 staticpro (&Qbufferp);
2102 staticpro (&Qvectorp);
2103 staticpro (&Qchar_or_string_p);
2104 staticpro (&Qmarkerp);
2105 staticpro (&Qbuffer_or_string_p);
2106 staticpro (&Qinteger_or_marker_p);
2107 #ifdef LISP_FLOAT_TYPE
2108 staticpro (&Qfloatp);
2109 staticpro (&Qnumberp);
2110 staticpro (&Qnumber_or_marker_p);
2111 #endif /* LISP_FLOAT_TYPE */
2113 staticpro (&Qboundp);
2114 staticpro (&Qfboundp);
2115 staticpro (&Qcdr);
2117 defsubr (&Seq);
2118 defsubr (&Snull);
2119 defsubr (&Slistp);
2120 defsubr (&Snlistp);
2121 defsubr (&Sconsp);
2122 defsubr (&Satom);
2123 defsubr (&Sintegerp);
2124 defsubr (&Sinteger_or_marker_p);
2125 defsubr (&Snumberp);
2126 defsubr (&Snumber_or_marker_p);
2127 #ifdef LISP_FLOAT_TYPE
2128 defsubr (&Sfloatp);
2129 #endif /* LISP_FLOAT_TYPE */
2130 defsubr (&Snatnump);
2131 defsubr (&Ssymbolp);
2132 defsubr (&Sstringp);
2133 defsubr (&Svectorp);
2134 defsubr (&Sarrayp);
2135 defsubr (&Ssequencep);
2136 defsubr (&Sbufferp);
2137 defsubr (&Smarkerp);
2138 defsubr (&Ssubrp);
2139 defsubr (&Sbyte_code_function_p);
2140 defsubr (&Schar_or_string_p);
2141 defsubr (&Scar);
2142 defsubr (&Scdr);
2143 defsubr (&Scar_safe);
2144 defsubr (&Scdr_safe);
2145 defsubr (&Ssetcar);
2146 defsubr (&Ssetcdr);
2147 defsubr (&Ssymbol_function);
2148 defsubr (&Sindirect_function);
2149 defsubr (&Ssymbol_plist);
2150 defsubr (&Ssymbol_name);
2151 defsubr (&Smakunbound);
2152 defsubr (&Sfmakunbound);
2153 defsubr (&Sboundp);
2154 defsubr (&Sfboundp);
2155 defsubr (&Sfset);
2156 defsubr (&Sdefalias);
2157 defsubr (&Ssetplist);
2158 defsubr (&Ssymbol_value);
2159 defsubr (&Sset);
2160 defsubr (&Sdefault_boundp);
2161 defsubr (&Sdefault_value);
2162 defsubr (&Sset_default);
2163 defsubr (&Ssetq_default);
2164 defsubr (&Smake_variable_buffer_local);
2165 defsubr (&Smake_local_variable);
2166 defsubr (&Skill_local_variable);
2167 defsubr (&Saref);
2168 defsubr (&Saset);
2169 defsubr (&Snumber_to_string);
2170 defsubr (&Sstring_to_number);
2171 defsubr (&Seqlsign);
2172 defsubr (&Slss);
2173 defsubr (&Sgtr);
2174 defsubr (&Sleq);
2175 defsubr (&Sgeq);
2176 defsubr (&Sneq);
2177 defsubr (&Szerop);
2178 defsubr (&Splus);
2179 defsubr (&Sminus);
2180 defsubr (&Stimes);
2181 defsubr (&Squo);
2182 defsubr (&Srem);
2183 defsubr (&Smax);
2184 defsubr (&Smin);
2185 defsubr (&Slogand);
2186 defsubr (&Slogior);
2187 defsubr (&Slogxor);
2188 defsubr (&Slsh);
2189 defsubr (&Sash);
2190 defsubr (&Sadd1);
2191 defsubr (&Ssub1);
2192 defsubr (&Slognot);
2195 SIGTYPE
2196 arith_error (signo)
2197 int signo;
2199 #ifdef USG
2200 /* USG systems forget handlers when they are used;
2201 must reestablish each time */
2202 signal (signo, arith_error);
2203 #endif /* USG */
2204 #ifdef VMS
2205 /* VMS systems are like USG. */
2206 signal (signo, arith_error);
2207 #endif /* VMS */
2208 #ifdef BSD4_1
2209 sigrelse (SIGFPE);
2210 #else /* not BSD4_1 */
2211 sigsetmask (SIGEMPTYMASK);
2212 #endif /* not BSD4_1 */
2214 Fsignal (Qarith_error, Qnil);
2217 init_data ()
2219 /* Don't do this if just dumping out.
2220 We don't want to call `signal' in this case
2221 so that we don't have trouble with dumping
2222 signal-delivering routines in an inconsistent state. */
2223 #ifndef CANNOT_DUMP
2224 if (!initialized)
2225 return;
2226 #endif /* CANNOT_DUMP */
2227 signal (SIGFPE, arith_error);
2229 #ifdef uts
2230 signal (SIGEMT, arith_error);
2231 #endif /* uts */