Warn rather than error when making a local var inside a let.
[bpt/emacs.git] / src / data.c
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.
5
6 This file is part of GNU Emacs.
7
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.
12
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.
17
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/>. */
20
21
22 #include <config.h>
23 #include <signal.h>
24 #include <stdio.h>
25 #include <setjmp.h>
26 #include "lisp.h"
27 #include "puresize.h"
28 #include "character.h"
29 #include "buffer.h"
30 #include "keyboard.h"
31 #include "frame.h"
32 #include "syssignal.h"
33 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
34 #include "font.h"
35
36 #ifdef STDC_HEADERS
37 #include <float.h>
38 #endif
39
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
45 #else
46 #define IEEE_FLOATING_POINT 0
47 #endif
48 #endif
49
50 #include <math.h>
51
52 #if !defined (atof)
53 extern double atof ();
54 #endif /* !atof */
55
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;
66
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;
73
74 Lisp_Object Qcdr;
75 Lisp_Object Qad_advice_info, Qad_activate_internal;
76
77 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
78 Lisp_Object Qoverflow_error, Qunderflow_error;
79
80 Lisp_Object Qfloatp;
81 Lisp_Object Qnumberp, Qnumber_or_marker_p;
82
83 Lisp_Object Qinteger;
84 static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
85 static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
86 Lisp_Object Qprocess;
87 static Lisp_Object Qcompiled_function, 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;
91
92 Lisp_Object Qinteractive_form;
93
94 static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
95
96 Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
97
98
99 void
100 circular_list_error (list)
101 Lisp_Object list;
102 {
103 xsignal (Qcircular_list, list);
104 }
105
106
107 Lisp_Object
108 wrong_type_argument (predicate, value)
109 register Lisp_Object predicate, value;
110 {
111 /* If VALUE is not even a valid Lisp object, we'd want to abort here
112 where we can get a backtrace showing where it came from. We used
113 to try and do that by checking the tagbits, but nowadays all
114 tagbits are potentially valid. */
115 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
116 * abort (); */
117
118 xsignal2 (Qwrong_type_argument, predicate, value);
119 }
120
121 void
122 pure_write_error ()
123 {
124 error ("Attempt to modify read-only object");
125 }
126
127 void
128 args_out_of_range (a1, a2)
129 Lisp_Object a1, a2;
130 {
131 xsignal2 (Qargs_out_of_range, a1, a2);
132 }
133
134 void
135 args_out_of_range_3 (a1, a2, a3)
136 Lisp_Object a1, a2, a3;
137 {
138 xsignal3 (Qargs_out_of_range, a1, a2, a3);
139 }
140
141 /* On some machines, XINT needs a temporary location.
142 Here it is, in case it is needed. */
143
144 int sign_extend_temp;
145
146 /* On a few machines, XINT can only be done by calling this. */
147
148 int
149 sign_extend_lisp_int (num)
150 EMACS_INT num;
151 {
152 if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
153 return num | (((EMACS_INT) (-1)) << VALBITS);
154 else
155 return num & ((((EMACS_INT) 1) << VALBITS) - 1);
156 }
157 \f
158 /* Data type predicates */
159
160 DEFUN ("eq", Feq, Seq, 2, 2, 0,
161 doc: /* Return t if the two args are the same Lisp object. */)
162 (obj1, obj2)
163 Lisp_Object obj1, obj2;
164 {
165 if (EQ (obj1, obj2))
166 return Qt;
167 return Qnil;
168 }
169
170 DEFUN ("null", Fnull, Snull, 1, 1, 0,
171 doc: /* Return t if OBJECT is nil. */)
172 (object)
173 Lisp_Object object;
174 {
175 if (NILP (object))
176 return Qt;
177 return Qnil;
178 }
179
180 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
181 doc: /* Return a symbol representing the type of OBJECT.
182 The symbol returned names the object's basic type;
183 for example, (type-of 1) returns `integer'. */)
184 (object)
185 Lisp_Object object;
186 {
187 switch (XTYPE (object))
188 {
189 case_Lisp_Int:
190 return Qinteger;
191
192 case Lisp_Symbol:
193 return Qsymbol;
194
195 case Lisp_String:
196 return Qstring;
197
198 case Lisp_Cons:
199 return Qcons;
200
201 case Lisp_Misc:
202 switch (XMISCTYPE (object))
203 {
204 case Lisp_Misc_Marker:
205 return Qmarker;
206 case Lisp_Misc_Overlay:
207 return Qoverlay;
208 case Lisp_Misc_Float:
209 return Qfloat;
210 }
211 abort ();
212
213 case Lisp_Vectorlike:
214 if (WINDOW_CONFIGURATIONP (object))
215 return Qwindow_configuration;
216 if (PROCESSP (object))
217 return Qprocess;
218 if (WINDOWP (object))
219 return Qwindow;
220 if (SUBRP (object))
221 return Qsubr;
222 if (COMPILEDP (object))
223 return Qcompiled_function;
224 if (BUFFERP (object))
225 return Qbuffer;
226 if (CHAR_TABLE_P (object))
227 return Qchar_table;
228 if (BOOL_VECTOR_P (object))
229 return Qbool_vector;
230 if (FRAMEP (object))
231 return Qframe;
232 if (HASH_TABLE_P (object))
233 return Qhash_table;
234 if (FONT_SPEC_P (object))
235 return Qfont_spec;
236 if (FONT_ENTITY_P (object))
237 return Qfont_entity;
238 if (FONT_OBJECT_P (object))
239 return Qfont_object;
240 return Qvector;
241
242 case Lisp_Float:
243 return Qfloat;
244
245 default:
246 abort ();
247 }
248 }
249
250 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
251 doc: /* Return t if OBJECT is a cons cell. */)
252 (object)
253 Lisp_Object object;
254 {
255 if (CONSP (object))
256 return Qt;
257 return Qnil;
258 }
259
260 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
261 doc: /* Return t if OBJECT is not a cons cell. This includes nil. */)
262 (object)
263 Lisp_Object object;
264 {
265 if (CONSP (object))
266 return Qnil;
267 return Qt;
268 }
269
270 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
271 doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
272 Otherwise, return nil. */)
273 (object)
274 Lisp_Object object;
275 {
276 if (CONSP (object) || NILP (object))
277 return Qt;
278 return Qnil;
279 }
280
281 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
282 doc: /* Return t if OBJECT is not a list. Lists include nil. */)
283 (object)
284 Lisp_Object object;
285 {
286 if (CONSP (object) || NILP (object))
287 return Qnil;
288 return Qt;
289 }
290 \f
291 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
292 doc: /* Return t if OBJECT is a symbol. */)
293 (object)
294 Lisp_Object object;
295 {
296 if (SYMBOLP (object))
297 return Qt;
298 return Qnil;
299 }
300
301 /* Define this in C to avoid unnecessarily consing up the symbol
302 name. */
303 DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
304 doc: /* Return t if OBJECT is a keyword.
305 This means that it is a symbol with a print name beginning with `:'
306 interned in the initial obarray. */)
307 (object)
308 Lisp_Object object;
309 {
310 if (SYMBOLP (object)
311 && SREF (SYMBOL_NAME (object), 0) == ':'
312 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
313 return Qt;
314 return Qnil;
315 }
316
317 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
318 doc: /* Return t if OBJECT is a vector. */)
319 (object)
320 Lisp_Object object;
321 {
322 if (VECTORP (object))
323 return Qt;
324 return Qnil;
325 }
326
327 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
328 doc: /* Return t if OBJECT is a string. */)
329 (object)
330 Lisp_Object object;
331 {
332 if (STRINGP (object))
333 return Qt;
334 return Qnil;
335 }
336
337 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
338 1, 1, 0,
339 doc: /* Return t if OBJECT is a multibyte string. */)
340 (object)
341 Lisp_Object object;
342 {
343 if (STRINGP (object) && STRING_MULTIBYTE (object))
344 return Qt;
345 return Qnil;
346 }
347
348 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
349 doc: /* Return t if OBJECT is a char-table. */)
350 (object)
351 Lisp_Object object;
352 {
353 if (CHAR_TABLE_P (object))
354 return Qt;
355 return Qnil;
356 }
357
358 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
359 Svector_or_char_table_p, 1, 1, 0,
360 doc: /* Return t if OBJECT is a char-table or vector. */)
361 (object)
362 Lisp_Object object;
363 {
364 if (VECTORP (object) || CHAR_TABLE_P (object))
365 return Qt;
366 return Qnil;
367 }
368
369 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
370 doc: /* Return t if OBJECT is a bool-vector. */)
371 (object)
372 Lisp_Object object;
373 {
374 if (BOOL_VECTOR_P (object))
375 return Qt;
376 return Qnil;
377 }
378
379 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
380 doc: /* Return t if OBJECT is an array (string or vector). */)
381 (object)
382 Lisp_Object object;
383 {
384 if (ARRAYP (object))
385 return Qt;
386 return Qnil;
387 }
388
389 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
390 doc: /* Return t if OBJECT is a sequence (list or array). */)
391 (object)
392 register Lisp_Object object;
393 {
394 if (CONSP (object) || NILP (object) || ARRAYP (object))
395 return Qt;
396 return Qnil;
397 }
398
399 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
400 doc: /* Return t if OBJECT is an editor buffer. */)
401 (object)
402 Lisp_Object object;
403 {
404 if (BUFFERP (object))
405 return Qt;
406 return Qnil;
407 }
408
409 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
410 doc: /* Return t if OBJECT is a marker (editor pointer). */)
411 (object)
412 Lisp_Object object;
413 {
414 if (MARKERP (object))
415 return Qt;
416 return Qnil;
417 }
418
419 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
420 doc: /* Return t if OBJECT is a built-in function. */)
421 (object)
422 Lisp_Object object;
423 {
424 if (SUBRP (object))
425 return Qt;
426 return Qnil;
427 }
428
429 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
430 1, 1, 0,
431 doc: /* Return t if OBJECT is a byte-compiled function object. */)
432 (object)
433 Lisp_Object object;
434 {
435 if (COMPILEDP (object))
436 return Qt;
437 return Qnil;
438 }
439
440 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
441 doc: /* Return t if OBJECT is a character or a string. */)
442 (object)
443 register Lisp_Object object;
444 {
445 if (CHARACTERP (object) || STRINGP (object))
446 return Qt;
447 return Qnil;
448 }
449 \f
450 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
451 doc: /* Return t if OBJECT is an integer. */)
452 (object)
453 Lisp_Object object;
454 {
455 if (INTEGERP (object))
456 return Qt;
457 return Qnil;
458 }
459
460 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
461 doc: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
462 (object)
463 register Lisp_Object object;
464 {
465 if (MARKERP (object) || INTEGERP (object))
466 return Qt;
467 return Qnil;
468 }
469
470 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
471 doc: /* Return t if OBJECT is a nonnegative integer. */)
472 (object)
473 Lisp_Object object;
474 {
475 if (NATNUMP (object))
476 return Qt;
477 return Qnil;
478 }
479
480 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
481 doc: /* Return t if OBJECT is a number (floating point or integer). */)
482 (object)
483 Lisp_Object object;
484 {
485 if (NUMBERP (object))
486 return Qt;
487 else
488 return Qnil;
489 }
490
491 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
492 Snumber_or_marker_p, 1, 1, 0,
493 doc: /* Return t if OBJECT is a number or a marker. */)
494 (object)
495 Lisp_Object object;
496 {
497 if (NUMBERP (object) || MARKERP (object))
498 return Qt;
499 return Qnil;
500 }
501
502 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
503 doc: /* Return t if OBJECT is a floating point number. */)
504 (object)
505 Lisp_Object object;
506 {
507 if (FLOATP (object))
508 return Qt;
509 return Qnil;
510 }
511
512 \f
513 /* Extract and set components of lists */
514
515 DEFUN ("car", Fcar, Scar, 1, 1, 0,
516 doc: /* Return the car of LIST. If arg is nil, return nil.
517 Error if arg is not nil and not a cons cell. See also `car-safe'.
518
519 See Info node `(elisp)Cons Cells' for a discussion of related basic
520 Lisp concepts such as car, cdr, cons cell and list. */)
521 (list)
522 register Lisp_Object list;
523 {
524 return CAR (list);
525 }
526
527 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
528 doc: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
529 (object)
530 Lisp_Object object;
531 {
532 return CAR_SAFE (object);
533 }
534
535 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
536 doc: /* Return the cdr of LIST. If arg is nil, return nil.
537 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
538
539 See Info node `(elisp)Cons Cells' for a discussion of related basic
540 Lisp concepts such as cdr, car, cons cell and list. */)
541 (list)
542 register Lisp_Object list;
543 {
544 return CDR (list);
545 }
546
547 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
548 doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
549 (object)
550 Lisp_Object object;
551 {
552 return CDR_SAFE (object);
553 }
554
555 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
556 doc: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
557 (cell, newcar)
558 register Lisp_Object cell, newcar;
559 {
560 CHECK_CONS (cell);
561 CHECK_IMPURE (cell);
562 XSETCAR (cell, newcar);
563 return newcar;
564 }
565
566 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
567 doc: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
568 (cell, newcdr)
569 register Lisp_Object cell, newcdr;
570 {
571 CHECK_CONS (cell);
572 CHECK_IMPURE (cell);
573 XSETCDR (cell, newcdr);
574 return newcdr;
575 }
576 \f
577 /* Extract and set components of symbols */
578
579 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
580 doc: /* Return t if SYMBOL's value is not void. */)
581 (symbol)
582 register Lisp_Object symbol;
583 {
584 Lisp_Object valcontents;
585 struct Lisp_Symbol *sym;
586 CHECK_SYMBOL (symbol);
587 sym = XSYMBOL (symbol);
588
589 start:
590 switch (sym->redirect)
591 {
592 case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
593 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
594 case SYMBOL_LOCALIZED:
595 {
596 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
597 if (blv->fwd)
598 /* In set_internal, we un-forward vars when their value is
599 set to Qunbound. */
600 return Qt;
601 else
602 {
603 swap_in_symval_forwarding (sym, blv);
604 valcontents = BLV_VALUE (blv);
605 }
606 break;
607 }
608 case SYMBOL_FORWARDED:
609 /* In set_internal, we un-forward vars when their value is
610 set to Qunbound. */
611 return Qt;
612 default: abort ();
613 }
614
615 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
616 }
617
618 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
619 doc: /* Return t if SYMBOL's function definition is not void. */)
620 (symbol)
621 register Lisp_Object symbol;
622 {
623 CHECK_SYMBOL (symbol);
624 return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
625 }
626
627 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
628 doc: /* Make SYMBOL's value be void.
629 Return SYMBOL. */)
630 (symbol)
631 register Lisp_Object symbol;
632 {
633 CHECK_SYMBOL (symbol);
634 if (SYMBOL_CONSTANT_P (symbol))
635 xsignal1 (Qsetting_constant, symbol);
636 Fset (symbol, Qunbound);
637 return symbol;
638 }
639
640 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
641 doc: /* Make SYMBOL's function definition be void.
642 Return SYMBOL. */)
643 (symbol)
644 register Lisp_Object symbol;
645 {
646 CHECK_SYMBOL (symbol);
647 if (NILP (symbol) || EQ (symbol, Qt))
648 xsignal1 (Qsetting_constant, symbol);
649 XSYMBOL (symbol)->function = Qunbound;
650 return symbol;
651 }
652
653 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
654 doc: /* Return SYMBOL's function definition. Error if that is void. */)
655 (symbol)
656 register Lisp_Object symbol;
657 {
658 CHECK_SYMBOL (symbol);
659 if (!EQ (XSYMBOL (symbol)->function, Qunbound))
660 return XSYMBOL (symbol)->function;
661 xsignal1 (Qvoid_function, symbol);
662 }
663
664 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
665 doc: /* Return SYMBOL's property list. */)
666 (symbol)
667 register Lisp_Object symbol;
668 {
669 CHECK_SYMBOL (symbol);
670 return XSYMBOL (symbol)->plist;
671 }
672
673 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
674 doc: /* Return SYMBOL's name, a string. */)
675 (symbol)
676 register Lisp_Object symbol;
677 {
678 register Lisp_Object name;
679
680 CHECK_SYMBOL (symbol);
681 name = SYMBOL_NAME (symbol);
682 return name;
683 }
684
685 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
686 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
687 (symbol, definition)
688 register Lisp_Object symbol, definition;
689 {
690 register Lisp_Object function;
691
692 CHECK_SYMBOL (symbol);
693 if (NILP (symbol) || EQ (symbol, Qt))
694 xsignal1 (Qsetting_constant, symbol);
695
696 function = XSYMBOL (symbol)->function;
697
698 if (!NILP (Vautoload_queue) && !EQ (function, Qunbound))
699 Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
700
701 if (CONSP (function) && EQ (XCAR (function), Qautoload))
702 Fput (symbol, Qautoload, XCDR (function));
703
704 XSYMBOL (symbol)->function = definition;
705 /* Handle automatic advice activation */
706 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
707 {
708 call2 (Qad_activate_internal, symbol, Qnil);
709 definition = XSYMBOL (symbol)->function;
710 }
711 return definition;
712 }
713
714 extern Lisp_Object Qfunction_documentation;
715
716 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
717 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
718 Associates the function with the current load file, if any.
719 The optional third argument DOCSTRING specifies the documentation string
720 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
721 determined by DEFINITION. */)
722 (symbol, definition, docstring)
723 register Lisp_Object symbol, definition, docstring;
724 {
725 CHECK_SYMBOL (symbol);
726 if (CONSP (XSYMBOL (symbol)->function)
727 && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
728 LOADHIST_ATTACH (Fcons (Qt, symbol));
729 definition = Ffset (symbol, definition);
730 LOADHIST_ATTACH (Fcons (Qdefun, symbol));
731 if (!NILP (docstring))
732 Fput (symbol, Qfunction_documentation, docstring);
733 return definition;
734 }
735
736 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
737 doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
738 (symbol, newplist)
739 register Lisp_Object symbol, newplist;
740 {
741 CHECK_SYMBOL (symbol);
742 XSYMBOL (symbol)->plist = newplist;
743 return newplist;
744 }
745
746 DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
747 doc: /* Return minimum and maximum number of args allowed for SUBR.
748 SUBR must be a built-in function.
749 The returned value is a pair (MIN . MAX). MIN is the minimum number
750 of args. MAX is the maximum number or the symbol `many', for a
751 function with `&rest' args, or `unevalled' for a special form. */)
752 (subr)
753 Lisp_Object subr;
754 {
755 short minargs, maxargs;
756 CHECK_SUBR (subr);
757 minargs = XSUBR (subr)->min_args;
758 maxargs = XSUBR (subr)->max_args;
759 if (maxargs == MANY)
760 return Fcons (make_number (minargs), Qmany);
761 else if (maxargs == UNEVALLED)
762 return Fcons (make_number (minargs), Qunevalled);
763 else
764 return Fcons (make_number (minargs), make_number (maxargs));
765 }
766
767 DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
768 doc: /* Return name of subroutine SUBR.
769 SUBR must be a built-in function. */)
770 (subr)
771 Lisp_Object subr;
772 {
773 const char *name;
774 CHECK_SUBR (subr);
775 name = XSUBR (subr)->symbol_name;
776 return make_string (name, strlen (name));
777 }
778
779 DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
780 doc: /* Return the interactive form of CMD or nil if none.
781 If CMD is not a command, the return value is nil.
782 Value, if non-nil, is a list \(interactive SPEC). */)
783 (cmd)
784 Lisp_Object cmd;
785 {
786 Lisp_Object fun = indirect_function (cmd); /* Check cycles. */
787
788 if (NILP (fun) || EQ (fun, Qunbound))
789 return Qnil;
790
791 /* Use an `interactive-form' property if present, analogous to the
792 function-documentation property. */
793 fun = cmd;
794 while (SYMBOLP (fun))
795 {
796 Lisp_Object tmp = Fget (fun, Qinteractive_form);
797 if (!NILP (tmp))
798 return tmp;
799 else
800 fun = Fsymbol_function (fun);
801 }
802
803 if (SUBRP (fun))
804 {
805 char *spec = XSUBR (fun)->intspec;
806 if (spec)
807 return list2 (Qinteractive,
808 (*spec != '(') ? build_string (spec) :
809 Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
810 }
811 else if (COMPILEDP (fun))
812 {
813 if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
814 return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
815 }
816 else if (CONSP (fun))
817 {
818 Lisp_Object funcar = XCAR (fun);
819 if (EQ (funcar, Qlambda))
820 return Fassq (Qinteractive, Fcdr (XCDR (fun)));
821 else if (EQ (funcar, Qautoload))
822 {
823 struct gcpro gcpro1;
824 GCPRO1 (cmd);
825 do_autoload (fun, cmd);
826 UNGCPRO;
827 return Finteractive_form (cmd);
828 }
829 }
830 return Qnil;
831 }
832
833 \f
834 /***********************************************************************
835 Getting and Setting Values of Symbols
836 ***********************************************************************/
837
838 /* Return the symbol holding SYMBOL's value. Signal
839 `cyclic-variable-indirection' if SYMBOL's chain of variable
840 indirections contains a loop. */
841
842 struct Lisp_Symbol *
843 indirect_variable (symbol)
844 struct Lisp_Symbol *symbol;
845 {
846 struct Lisp_Symbol *tortoise, *hare;
847
848 hare = tortoise = symbol;
849
850 while (hare->redirect == SYMBOL_VARALIAS)
851 {
852 hare = SYMBOL_ALIAS (hare);
853 if (hare->redirect != SYMBOL_VARALIAS)
854 break;
855
856 hare = SYMBOL_ALIAS (hare);
857 tortoise = SYMBOL_ALIAS (tortoise);
858
859 if (hare == tortoise)
860 {
861 Lisp_Object tem;
862 XSETSYMBOL (tem, symbol);
863 xsignal1 (Qcyclic_variable_indirection, tem);
864 }
865 }
866
867 return hare;
868 }
869
870
871 DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
872 doc: /* Return the variable at the end of OBJECT's variable chain.
873 If OBJECT is a symbol, follow all variable indirections and return the final
874 variable. If OBJECT is not a symbol, just return it.
875 Signal a cyclic-variable-indirection error if there is a loop in the
876 variable chain of symbols. */)
877 (object)
878 Lisp_Object object;
879 {
880 if (SYMBOLP (object))
881 XSETSYMBOL (object, indirect_variable (XSYMBOL (object)));
882 return object;
883 }
884
885
886 /* Given the raw contents of a symbol value cell,
887 return the Lisp value of the symbol.
888 This does not handle buffer-local variables; use
889 swap_in_symval_forwarding for that. */
890
891 #define do_blv_forwarding(blv) \
892 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
893
894 Lisp_Object
895 do_symval_forwarding (valcontents)
896 register union Lisp_Fwd *valcontents;
897 {
898 register Lisp_Object val;
899 switch (XFWDTYPE (valcontents))
900 {
901 case Lisp_Fwd_Int:
902 XSETINT (val, *XINTFWD (valcontents)->intvar);
903 return val;
904
905 case Lisp_Fwd_Bool:
906 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
907
908 case Lisp_Fwd_Obj:
909 return *XOBJFWD (valcontents)->objvar;
910
911 case Lisp_Fwd_Buffer_Obj:
912 return PER_BUFFER_VALUE (current_buffer,
913 XBUFFER_OBJFWD (valcontents)->offset);
914
915 case Lisp_Fwd_Kboard_Obj:
916 /* We used to simply use current_kboard here, but from Lisp
917 code, it's value is often unexpected. It seems nicer to
918 allow constructions like this to work as intuitively expected:
919
920 (with-selected-frame frame
921 (define-key local-function-map "\eOP" [f1]))
922
923 On the other hand, this affects the semantics of
924 last-command and real-last-command, and people may rely on
925 that. I took a quick look at the Lisp codebase, and I
926 don't think anything will break. --lorentey */
927 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
928 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
929 default: abort ();
930 }
931 }
932
933 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
934 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
935 buffer-independent contents of the value cell: forwarded just one
936 step past the buffer-localness.
937
938 BUF non-zero means set the value in buffer BUF instead of the
939 current buffer. This only plays a role for per-buffer variables. */
940
941 #define store_blv_forwarding(blv, newval, buf) \
942 do { \
943 if ((blv)->forwarded) \
944 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
945 else \
946 SET_BLV_VALUE (blv, newval); \
947 } while (0)
948
949 static void
950 store_symval_forwarding (/* symbol, */ valcontents, newval, buf)
951 /* struct Lisp_Symbol *symbol; */
952 union Lisp_Fwd *valcontents;
953 register Lisp_Object newval;
954 struct buffer *buf;
955 {
956 switch (XFWDTYPE (valcontents))
957 {
958 case Lisp_Fwd_Int:
959 CHECK_NUMBER (newval);
960 *XINTFWD (valcontents)->intvar = XINT (newval);
961 break;
962
963 case Lisp_Fwd_Bool:
964 *XBOOLFWD (valcontents)->boolvar = !NILP (newval);
965 break;
966
967 case Lisp_Fwd_Obj:
968 *XOBJFWD (valcontents)->objvar = newval;
969
970 /* If this variable is a default for something stored
971 in the buffer itself, such as default-fill-column,
972 find the buffers that don't have local values for it
973 and update them. */
974 if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults
975 && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1))
976 {
977 int offset = ((char *) XOBJFWD (valcontents)->objvar
978 - (char *) &buffer_defaults);
979 int idx = PER_BUFFER_IDX (offset);
980
981 Lisp_Object tail;
982
983 if (idx <= 0)
984 break;
985
986 for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
987 {
988 Lisp_Object buf;
989 struct buffer *b;
990
991 buf = Fcdr (XCAR (tail));
992 if (!BUFFERP (buf)) continue;
993 b = XBUFFER (buf);
994
995 if (! PER_BUFFER_VALUE_P (b, idx))
996 PER_BUFFER_VALUE (b, offset) = newval;
997 }
998 }
999 break;
1000
1001 case Lisp_Fwd_Buffer_Obj:
1002 {
1003 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1004 Lisp_Object type = XBUFFER_OBJFWD (valcontents)->slottype;
1005
1006 if (!(NILP (type) || NILP (newval)
1007 || (XINT (type) == LISP_INT_TAG
1008 ? INTEGERP (newval)
1009 : XTYPE (newval) == XINT (type))))
1010 buffer_slot_type_mismatch (newval, XINT (type));
1011
1012 if (buf == NULL)
1013 buf = current_buffer;
1014 PER_BUFFER_VALUE (buf, offset) = newval;
1015 }
1016 break;
1017
1018 case Lisp_Fwd_Kboard_Obj:
1019 {
1020 char *base = (char *) FRAME_KBOARD (SELECTED_FRAME ());
1021 char *p = base + XKBOARD_OBJFWD (valcontents)->offset;
1022 *(Lisp_Object *) p = newval;
1023 }
1024 break;
1025
1026 default:
1027 abort (); /* goto def; */
1028 }
1029 }
1030
1031 /* Set up SYMBOL to refer to its global binding.
1032 This makes it safe to alter the status of other bindings. */
1033
1034 void
1035 swap_in_global_binding (symbol)
1036 struct Lisp_Symbol *symbol;
1037 {
1038 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
1039
1040 /* Unload the previously loaded binding. */
1041 if (blv->fwd)
1042 SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
1043
1044 /* Select the global binding in the symbol. */
1045 blv->valcell = blv->defcell;
1046 if (blv->fwd)
1047 store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL);
1048
1049 /* Indicate that the global binding is set up now. */
1050 blv->where = Qnil;
1051 SET_BLV_FOUND (blv, 0);
1052 }
1053
1054 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1055 VALCONTENTS is the contents of its value cell,
1056 which points to a struct Lisp_Buffer_Local_Value.
1057
1058 Return the value forwarded one step past the buffer-local stage.
1059 This could be another forwarding pointer. */
1060
1061 static void
1062 swap_in_symval_forwarding (symbol, blv)
1063 struct Lisp_Symbol *symbol;
1064 struct Lisp_Buffer_Local_Value *blv;
1065 {
1066 register Lisp_Object tem1;
1067
1068 eassert (blv == SYMBOL_BLV (symbol));
1069
1070 tem1 = blv->where;
1071
1072 if (NILP (tem1)
1073 || (blv->frame_local
1074 ? !EQ (selected_frame, tem1)
1075 : current_buffer != XBUFFER (tem1)))
1076 {
1077
1078 /* Unload the previously loaded binding. */
1079 tem1 = blv->valcell;
1080 if (blv->fwd)
1081 SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
1082 /* Choose the new binding. */
1083 {
1084 Lisp_Object var;
1085 XSETSYMBOL (var, symbol);
1086 if (blv->frame_local)
1087 {
1088 tem1 = assq_no_quit (var, XFRAME (selected_frame)->param_alist);
1089 blv->where = selected_frame;
1090 }
1091 else
1092 {
1093 tem1 = assq_no_quit (var, current_buffer->local_var_alist);
1094 XSETBUFFER (blv->where, current_buffer);
1095 }
1096 }
1097 if (!(blv->found = !NILP (tem1)))
1098 tem1 = blv->defcell;
1099
1100 /* Load the new binding. */
1101 blv->valcell = tem1;
1102 if (blv->fwd)
1103 store_symval_forwarding (blv->fwd, BLV_VALUE (blv), NULL);
1104 }
1105 }
1106 \f
1107 /* Find the value of a symbol, returning Qunbound if it's not bound.
1108 This is helpful for code which just wants to get a variable's value
1109 if it has one, without signaling an error.
1110 Note that it must not be possible to quit
1111 within this function. Great care is required for this. */
1112
1113 Lisp_Object
1114 find_symbol_value (symbol)
1115 Lisp_Object symbol;
1116 {
1117 struct Lisp_Symbol *sym;
1118
1119 CHECK_SYMBOL (symbol);
1120 sym = XSYMBOL (symbol);
1121
1122 start:
1123 switch (sym->redirect)
1124 {
1125 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1126 case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1127 case SYMBOL_LOCALIZED:
1128 {
1129 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1130 swap_in_symval_forwarding (sym, blv);
1131 return blv->fwd ? do_symval_forwarding (blv->fwd) : BLV_VALUE (blv);
1132 }
1133 /* FALLTHROUGH */
1134 case SYMBOL_FORWARDED:
1135 return do_symval_forwarding (SYMBOL_FWD (sym));
1136 default: abort ();
1137 }
1138 }
1139
1140 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
1141 doc: /* Return SYMBOL's value. Error if that is void. */)
1142 (symbol)
1143 Lisp_Object symbol;
1144 {
1145 Lisp_Object val;
1146
1147 val = find_symbol_value (symbol);
1148 if (!EQ (val, Qunbound))
1149 return val;
1150
1151 xsignal1 (Qvoid_variable, symbol);
1152 }
1153
1154 DEFUN ("set", Fset, Sset, 2, 2, 0,
1155 doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1156 (symbol, newval)
1157 register Lisp_Object symbol, newval;
1158 {
1159 set_internal (symbol, newval, current_buffer, 0);
1160 return newval;
1161 }
1162
1163 /* Return 1 if SYMBOL currently has a let-binding
1164 which was made in the buffer that is now current. */
1165
1166 static int
1167 let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
1168 {
1169 struct specbinding *p;
1170
1171 for (p = specpdl_ptr - 1; p >= specpdl; p--)
1172 if (p->func == NULL
1173 && CONSP (p->symbol))
1174 {
1175 struct Lisp_Symbol *let_bound_symbol = XSYMBOL (XCAR (p->symbol));
1176 eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
1177 if (symbol == let_bound_symbol
1178 && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
1179 break;
1180 }
1181
1182 return p >= specpdl;
1183 }
1184
1185 static int
1186 let_shadows_global_binding_p (symbol)
1187 Lisp_Object symbol;
1188 {
1189 struct specbinding *p;
1190
1191 for (p = specpdl_ptr - 1; p >= specpdl; p--)
1192 if (p->func == NULL && EQ (p->symbol, symbol))
1193 break;
1194
1195 return p >= specpdl;
1196 }
1197
1198 /* Store the value NEWVAL into SYMBOL.
1199 If buffer-locality is an issue, BUF specifies which buffer to use.
1200 (0 stands for the current buffer.)
1201
1202 If BINDFLAG is zero, then if this symbol is supposed to become
1203 local in every buffer where it is set, then we make it local.
1204 If BINDFLAG is nonzero, we don't do that. */
1205
1206 void
1207 set_internal (symbol, newval, buf, bindflag)
1208 register Lisp_Object symbol, newval;
1209 struct buffer *buf;
1210 int bindflag;
1211 {
1212 int voide = EQ (newval, Qunbound);
1213 struct Lisp_Symbol *sym;
1214 Lisp_Object tem1;
1215
1216 if (buf == 0)
1217 buf = current_buffer;
1218
1219 /* If restoring in a dead buffer, do nothing. */
1220 if (NILP (buf->name))
1221 return;
1222
1223 CHECK_SYMBOL (symbol);
1224 if (SYMBOL_CONSTANT_P (symbol))
1225 {
1226 if (NILP (Fkeywordp (symbol))
1227 || !EQ (newval, Fsymbol_value (symbol)))
1228 xsignal1 (Qsetting_constant, symbol);
1229 else
1230 /* Allow setting keywords to their own value. */
1231 return;
1232 }
1233
1234 sym = XSYMBOL (symbol);
1235
1236 start:
1237 switch (sym->redirect)
1238 {
1239 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1240 case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
1241 case SYMBOL_LOCALIZED:
1242 {
1243 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1244 Lisp_Object tmp; XSETBUFFER (tmp, buf);
1245
1246 /* If the current buffer is not the buffer whose binding is
1247 loaded, or if there may be frame-local bindings and the frame
1248 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1249 the default binding is loaded, the loaded binding may be the
1250 wrong one. */
1251 if (!EQ (blv->where,
1252 blv->frame_local ? selected_frame : tmp)
1253 /* Also unload a global binding (if the var is local_if_set). */
1254 || (EQ (blv->valcell, blv->defcell)))
1255 {
1256 /* The currently loaded binding is not necessarily valid.
1257 We need to unload it, and choose a new binding. */
1258
1259 /* Write out `realvalue' to the old loaded binding. */
1260 if (blv->fwd)
1261 SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
1262
1263 /* Find the new binding. */
1264 {
1265 XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */
1266 if (blv->frame_local)
1267 {
1268 tem1 = Fassq (symbol, XFRAME (selected_frame)->param_alist);
1269 blv->where = selected_frame;
1270 }
1271 else
1272 {
1273 tem1 = Fassq (symbol, buf->local_var_alist);
1274 blv->where = tmp;
1275 }
1276 }
1277 blv->found = 1;
1278
1279 if (NILP (tem1))
1280 {
1281 /* This buffer still sees the default value. */
1282
1283 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1284 or if this is `let' rather than `set',
1285 make CURRENT-ALIST-ELEMENT point to itself,
1286 indicating that we're seeing the default value.
1287 Likewise if the variable has been let-bound
1288 in the current buffer. */
1289 if (bindflag || !blv->local_if_set
1290 || let_shadows_buffer_binding_p (sym))
1291 {
1292 blv->found = 0;
1293 tem1 = blv->defcell;
1294 }
1295 /* If it's a local_if_set, being set not bound,
1296 and we're not within a let that was made for this buffer,
1297 create a new buffer-local binding for the variable.
1298 That means, give this buffer a new assoc for a local value
1299 and load that binding. */
1300 else
1301 {
1302 /* local_if_set is only supported for buffer-local
1303 bindings, not for frame-local bindings. */
1304 eassert (!blv->frame_local);
1305 tem1 = Fcons (symbol, XCDR (blv->defcell));
1306 buf->local_var_alist
1307 = Fcons (tem1, buf->local_var_alist);
1308 }
1309 }
1310
1311 /* Record which binding is now loaded. */
1312 blv->valcell = tem1;
1313 }
1314
1315 /* Store the new value in the cons cell. */
1316 SET_BLV_VALUE (blv, newval);
1317
1318 if (blv->fwd)
1319 {
1320 if (voide)
1321 /* If storing void (making the symbol void), forward only through
1322 buffer-local indicator, not through Lisp_Objfwd, etc. */
1323 blv->fwd = NULL;
1324 else
1325 store_symval_forwarding (blv->fwd, newval, buf);
1326 }
1327 break;
1328 }
1329 case SYMBOL_FORWARDED:
1330 {
1331 union Lisp_Fwd *innercontents = SYMBOL_FWD (sym);
1332 if (BUFFER_OBJFWDP (innercontents))
1333 {
1334 int offset = XBUFFER_OBJFWD (innercontents)->offset;
1335 int idx = PER_BUFFER_IDX (offset);
1336 if (idx > 0
1337 && !bindflag
1338 && !let_shadows_buffer_binding_p (sym))
1339 SET_PER_BUFFER_VALUE_P (buf, idx, 1);
1340 }
1341
1342 if (voide)
1343 { /* If storing void (making the symbol void), forward only through
1344 buffer-local indicator, not through Lisp_Objfwd, etc. */
1345 sym->redirect = SYMBOL_PLAINVAL;
1346 SET_SYMBOL_VAL (sym, newval);
1347 }
1348 else
1349 store_symval_forwarding (/* sym, */ innercontents, newval, buf);
1350 break;
1351 }
1352 default: abort ();
1353 }
1354 return;
1355 }
1356 \f
1357 /* Access or set a buffer-local symbol's default value. */
1358
1359 /* Return the default value of SYMBOL, but don't check for voidness.
1360 Return Qunbound if it is void. */
1361
1362 Lisp_Object
1363 default_value (symbol)
1364 Lisp_Object symbol;
1365 {
1366 struct Lisp_Symbol *sym;
1367
1368 CHECK_SYMBOL (symbol);
1369 sym = XSYMBOL (symbol);
1370
1371 start:
1372 switch (sym->redirect)
1373 {
1374 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1375 case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1376 case SYMBOL_LOCALIZED:
1377 {
1378 /* If var is set up for a buffer that lacks a local value for it,
1379 the current value is nominally the default value.
1380 But the `realvalue' slot may be more up to date, since
1381 ordinary setq stores just that slot. So use that. */
1382 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1383 if (blv->fwd && EQ (blv->valcell, blv->defcell))
1384 return do_symval_forwarding (blv->fwd);
1385 else
1386 return XCDR (blv->defcell);
1387 }
1388 case SYMBOL_FORWARDED:
1389 {
1390 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1391
1392 /* For a built-in buffer-local variable, get the default value
1393 rather than letting do_symval_forwarding get the current value. */
1394 if (BUFFER_OBJFWDP (valcontents))
1395 {
1396 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1397 if (PER_BUFFER_IDX (offset) != 0)
1398 return PER_BUFFER_DEFAULT (offset);
1399 }
1400
1401 /* For other variables, get the current value. */
1402 return do_symval_forwarding (valcontents);
1403 }
1404 default: abort ();
1405 }
1406 }
1407
1408 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1409 doc: /* Return t if SYMBOL has a non-void default value.
1410 This is the value that is seen in buffers that do not have their own values
1411 for this variable. */)
1412 (symbol)
1413 Lisp_Object symbol;
1414 {
1415 register Lisp_Object value;
1416
1417 value = default_value (symbol);
1418 return (EQ (value, Qunbound) ? Qnil : Qt);
1419 }
1420
1421 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1422 doc: /* Return SYMBOL's default value.
1423 This is the value that is seen in buffers that do not have their own values
1424 for this variable. The default value is meaningful for variables with
1425 local bindings in certain buffers. */)
1426 (symbol)
1427 Lisp_Object symbol;
1428 {
1429 register Lisp_Object value;
1430
1431 value = default_value (symbol);
1432 if (!EQ (value, Qunbound))
1433 return value;
1434
1435 xsignal1 (Qvoid_variable, symbol);
1436 }
1437
1438 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1439 doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1440 The default value is seen in buffers that do not have their own values
1441 for this variable. */)
1442 (symbol, value)
1443 Lisp_Object symbol, value;
1444 {
1445 struct Lisp_Symbol *sym;
1446
1447 CHECK_SYMBOL (symbol);
1448 if (SYMBOL_CONSTANT_P (symbol))
1449 {
1450 if (NILP (Fkeywordp (symbol))
1451 || !EQ (value, Fdefault_value (symbol)))
1452 xsignal1 (Qsetting_constant, symbol);
1453 else
1454 /* Allow setting keywords to their own value. */
1455 return value;
1456 }
1457 sym = XSYMBOL (symbol);
1458
1459 start:
1460 switch (sym->redirect)
1461 {
1462 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1463 case SYMBOL_PLAINVAL: return Fset (symbol, value);
1464 case SYMBOL_LOCALIZED:
1465 {
1466 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1467
1468 /* Store new value into the DEFAULT-VALUE slot. */
1469 XSETCDR (blv->defcell, value);
1470
1471 /* If the default binding is now loaded, set the REALVALUE slot too. */
1472 if (blv->fwd && EQ (blv->defcell, blv->valcell))
1473 store_symval_forwarding (blv->fwd, value, NULL);
1474 return value;
1475 }
1476 case SYMBOL_FORWARDED:
1477 {
1478 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1479
1480 /* Handle variables like case-fold-search that have special slots
1481 in the buffer.
1482 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1483 if (BUFFER_OBJFWDP (valcontents))
1484 {
1485 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1486 int idx = PER_BUFFER_IDX (offset);
1487
1488 PER_BUFFER_DEFAULT (offset) = value;
1489
1490 /* If this variable is not always local in all buffers,
1491 set it in the buffers that don't nominally have a local value. */
1492 if (idx > 0)
1493 {
1494 struct buffer *b;
1495
1496 for (b = all_buffers; b; b = b->next)
1497 if (!PER_BUFFER_VALUE_P (b, idx))
1498 PER_BUFFER_VALUE (b, offset) = value;
1499 }
1500 return value;
1501 }
1502 else
1503 return Fset (symbol, value);
1504 }
1505 default: abort ();
1506 }
1507 }
1508
1509 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
1510 doc: /* Set the default value of variable VAR to VALUE.
1511 VAR, the variable name, is literal (not evaluated);
1512 VALUE is an expression: it is evaluated and its value returned.
1513 The default value of a variable is seen in buffers
1514 that do not have their own values for the variable.
1515
1516 More generally, you can use multiple variables and values, as in
1517 (setq-default VAR VALUE VAR VALUE...)
1518 This sets each VAR's default value to the corresponding VALUE.
1519 The VALUE for the Nth VAR can refer to the new default values
1520 of previous VARs.
1521 usage: (setq-default [VAR VALUE]...) */)
1522 (args)
1523 Lisp_Object args;
1524 {
1525 register Lisp_Object args_left;
1526 register Lisp_Object val, symbol;
1527 struct gcpro gcpro1;
1528
1529 if (NILP (args))
1530 return Qnil;
1531
1532 args_left = args;
1533 GCPRO1 (args);
1534
1535 do
1536 {
1537 val = Feval (Fcar (Fcdr (args_left)));
1538 symbol = XCAR (args_left);
1539 Fset_default (symbol, val);
1540 args_left = Fcdr (XCDR (args_left));
1541 }
1542 while (!NILP (args_left));
1543
1544 UNGCPRO;
1545 return val;
1546 }
1547 \f
1548 /* Lisp functions for creating and removing buffer-local variables. */
1549
1550 union Lisp_Val_Fwd
1551 {
1552 Lisp_Object value;
1553 union Lisp_Fwd *fwd;
1554 };
1555
1556 static struct Lisp_Buffer_Local_Value *
1557 make_blv (struct Lisp_Symbol *sym, int forwarded, union Lisp_Val_Fwd valcontents)
1558 {
1559 struct Lisp_Buffer_Local_Value *blv
1560 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value));
1561 Lisp_Object symbol; XSETSYMBOL (symbol, sym);
1562 Lisp_Object tem = Fcons (symbol, (forwarded
1563 ? do_symval_forwarding (valcontents.fwd)
1564 : valcontents.value));
1565 /* Buffer_Local_Values cannot have as realval a buffer-local
1566 or keyboard-local forwarding. */
1567 eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd)));
1568 eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
1569 blv->fwd = forwarded ? valcontents.fwd : NULL;
1570 blv->where = Qnil;
1571 blv->frame_local = 0;
1572 blv->local_if_set = 0;
1573 blv->defcell = tem;
1574 blv->valcell = tem;
1575 SET_BLV_FOUND (blv, 0);
1576 return blv;
1577 }
1578
1579 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1580 1, 1, "vMake Variable Buffer Local: ",
1581 doc: /* Make VARIABLE become buffer-local whenever it is set.
1582 At any time, the value for the current buffer is in effect,
1583 unless the variable has never been set in this buffer,
1584 in which case the default value is in effect.
1585 Note that binding the variable with `let', or setting it while
1586 a `let'-style binding made in this buffer is in effect,
1587 does not make the variable buffer-local. Return VARIABLE.
1588
1589 In most cases it is better to use `make-local-variable',
1590 which makes a variable local in just one buffer.
1591
1592 The function `default-value' gets the default value and `set-default' sets it. */)
1593 (variable)
1594 register Lisp_Object variable;
1595 {
1596 struct Lisp_Symbol *sym;
1597 struct Lisp_Buffer_Local_Value *blv = NULL;
1598 union Lisp_Val_Fwd valcontents;
1599 int forwarded;
1600
1601 CHECK_SYMBOL (variable);
1602 sym = XSYMBOL (variable);
1603
1604 start:
1605 switch (sym->redirect)
1606 {
1607 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1608 case SYMBOL_PLAINVAL:
1609 forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1610 if (EQ (valcontents.value, Qunbound))
1611 valcontents.value = Qnil;
1612 break;
1613 case SYMBOL_LOCALIZED:
1614 blv = SYMBOL_BLV (sym);
1615 if (blv->frame_local)
1616 error ("Symbol %s may not be buffer-local",
1617 SDATA (SYMBOL_NAME (variable)));
1618 break;
1619 case SYMBOL_FORWARDED:
1620 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1621 if (KBOARD_OBJFWDP (valcontents.fwd))
1622 error ("Symbol %s may not be buffer-local",
1623 SDATA (SYMBOL_NAME (variable)));
1624 else if (BUFFER_OBJFWDP (valcontents.fwd))
1625 return variable;
1626 break;
1627 default: abort ();
1628 }
1629
1630 if (sym->constant)
1631 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
1632
1633 if (!blv)
1634 {
1635 blv = make_blv (sym, forwarded, valcontents);
1636 sym->redirect = SYMBOL_LOCALIZED;
1637 SET_SYMBOL_BLV (sym, blv);
1638 {
1639 Lisp_Object symbol;
1640 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1641 if (let_shadows_global_binding_p (symbol))
1642 message ("Making %s buffer-local while let-bound!",
1643 SDATA (SYMBOL_NAME (variable)));
1644 }
1645 }
1646
1647 blv->local_if_set = 1;
1648 return variable;
1649 }
1650
1651 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1652 1, 1, "vMake Local Variable: ",
1653 doc: /* Make VARIABLE have a separate value in the current buffer.
1654 Other buffers will continue to share a common default value.
1655 \(The buffer-local value of VARIABLE starts out as the same value
1656 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1657 Return VARIABLE.
1658
1659 If the variable is already arranged to become local when set,
1660 this function causes a local value to exist for this buffer,
1661 just as setting the variable would do.
1662
1663 This function returns VARIABLE, and therefore
1664 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1665 works.
1666
1667 See also `make-variable-buffer-local'.
1668
1669 Do not use `make-local-variable' to make a hook variable buffer-local.
1670 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1671 (variable)
1672 register Lisp_Object variable;
1673 {
1674 register Lisp_Object tem;
1675 int forwarded;
1676 union Lisp_Val_Fwd valcontents;
1677 struct Lisp_Symbol *sym;
1678 struct Lisp_Buffer_Local_Value *blv = NULL;
1679
1680 CHECK_SYMBOL (variable);
1681 sym = XSYMBOL (variable);
1682
1683 start:
1684 switch (sym->redirect)
1685 {
1686 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1687 case SYMBOL_PLAINVAL:
1688 forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break;
1689 case SYMBOL_LOCALIZED:
1690 blv = SYMBOL_BLV (sym);
1691 if (blv->frame_local)
1692 error ("Symbol %s may not be buffer-local",
1693 SDATA (SYMBOL_NAME (variable)));
1694 break;
1695 case SYMBOL_FORWARDED:
1696 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1697 if (KBOARD_OBJFWDP (valcontents.fwd))
1698 error ("Symbol %s may not be buffer-local",
1699 SDATA (SYMBOL_NAME (variable)));
1700 break;
1701 default: abort ();
1702 }
1703
1704 if (sym->constant)
1705 error ("Symbol %s may not be buffer-local",
1706 SDATA (SYMBOL_NAME (variable)));
1707
1708 if (blv ? blv->local_if_set
1709 : (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
1710 {
1711 tem = Fboundp (variable);
1712 /* Make sure the symbol has a local value in this particular buffer,
1713 by setting it to the same value it already has. */
1714 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1715 return variable;
1716 }
1717 if (!blv)
1718 {
1719 blv = make_blv (sym, forwarded, valcontents);
1720 sym->redirect = SYMBOL_LOCALIZED;
1721 SET_SYMBOL_BLV (sym, blv);
1722 {
1723 Lisp_Object symbol;
1724 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1725 if (let_shadows_global_binding_p (symbol))
1726 message ("Making %s local to %s while let-bound!",
1727 SDATA (SYMBOL_NAME (variable)),
1728 SDATA (current_buffer->name));
1729 }
1730 }
1731
1732 /* Make sure this buffer has its own value of symbol. */
1733 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1734 tem = Fassq (variable, current_buffer->local_var_alist);
1735 if (NILP (tem))
1736 {
1737 if (let_shadows_buffer_binding_p (sym))
1738 message ("Making %s buffer-local while locally let-bound!",
1739 SDATA (SYMBOL_NAME (variable)));
1740
1741 /* Swap out any local binding for some other buffer, and make
1742 sure the current value is permanently recorded, if it's the
1743 default value. */
1744 find_symbol_value (variable);
1745
1746 current_buffer->local_var_alist
1747 = Fcons (Fcons (variable, XCDR (blv->defcell)),
1748 current_buffer->local_var_alist);
1749
1750 /* Make sure symbol does not think it is set up for this buffer;
1751 force it to look once again for this buffer's value. */
1752 if (current_buffer == XBUFFER (blv->where))
1753 blv->where = Qnil;
1754 /* blv->valcell = blv->defcell;
1755 * SET_BLV_FOUND (blv, 0); */
1756 blv->found = 0;
1757 }
1758
1759 /* If the symbol forwards into a C variable, then load the binding
1760 for this buffer now. If C code modifies the variable before we
1761 load the binding in, then that new value will clobber the default
1762 binding the next time we unload it. */
1763 if (blv->fwd)
1764 swap_in_symval_forwarding (sym, blv);
1765
1766 return variable;
1767 }
1768
1769 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1770 1, 1, "vKill Local Variable: ",
1771 doc: /* Make VARIABLE no longer have a separate value in the current buffer.
1772 From now on the default value will apply in this buffer. Return VARIABLE. */)
1773 (variable)
1774 register Lisp_Object variable;
1775 {
1776 register Lisp_Object tem;
1777 struct Lisp_Buffer_Local_Value *blv;
1778 struct Lisp_Symbol *sym;
1779
1780 CHECK_SYMBOL (variable);
1781 sym = XSYMBOL (variable);
1782
1783 start:
1784 switch (sym->redirect)
1785 {
1786 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1787 case SYMBOL_PLAINVAL: return variable;
1788 case SYMBOL_FORWARDED:
1789 {
1790 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1791 if (BUFFER_OBJFWDP (valcontents))
1792 {
1793 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1794 int idx = PER_BUFFER_IDX (offset);
1795
1796 if (idx > 0)
1797 {
1798 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
1799 PER_BUFFER_VALUE (current_buffer, offset)
1800 = PER_BUFFER_DEFAULT (offset);
1801 }
1802 }
1803 return variable;
1804 }
1805 case SYMBOL_LOCALIZED:
1806 blv = SYMBOL_BLV (sym);
1807 if (blv->frame_local)
1808 return variable;
1809 break;
1810 default: abort ();
1811 }
1812
1813 /* Get rid of this buffer's alist element, if any. */
1814 XSETSYMBOL (variable, sym); /* Propagate variable indirection. */
1815 tem = Fassq (variable, current_buffer->local_var_alist);
1816 if (!NILP (tem))
1817 current_buffer->local_var_alist
1818 = Fdelq (tem, current_buffer->local_var_alist);
1819
1820 /* If the symbol is set up with the current buffer's binding
1821 loaded, recompute its value. We have to do it now, or else
1822 forwarded objects won't work right. */
1823 {
1824 Lisp_Object buf; XSETBUFFER (buf, current_buffer);
1825 if (EQ (buf, blv->where))
1826 {
1827 blv->where = Qnil;
1828 /* blv->valcell = blv->defcell;
1829 * SET_BLV_FOUND (blv, 0); */
1830 blv->found = 0;
1831 find_symbol_value (variable);
1832 }
1833 }
1834
1835 return variable;
1836 }
1837
1838 /* Lisp functions for creating and removing buffer-local variables. */
1839
1840 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1841 when/if this is removed. */
1842
1843 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1844 1, 1, "vMake Variable Frame Local: ",
1845 doc: /* Enable VARIABLE to have frame-local bindings.
1846 This does not create any frame-local bindings for VARIABLE,
1847 it just makes them possible.
1848
1849 A frame-local binding is actually a frame parameter value.
1850 If a frame F has a value for the frame parameter named VARIABLE,
1851 that also acts as a frame-local binding for VARIABLE in F--
1852 provided this function has been called to enable VARIABLE
1853 to have frame-local bindings at all.
1854
1855 The only way to create a frame-local binding for VARIABLE in a frame
1856 is to set the VARIABLE frame parameter of that frame. See
1857 `modify-frame-parameters' for how to set frame parameters.
1858
1859 Note that since Emacs 23.1, variables cannot be both buffer-local and
1860 frame-local any more (buffer-local bindings used to take precedence over
1861 frame-local bindings). */)
1862 (variable)
1863 register Lisp_Object variable;
1864 {
1865 int forwarded;
1866 union Lisp_Val_Fwd valcontents;
1867 struct Lisp_Symbol *sym;
1868 struct Lisp_Buffer_Local_Value *blv = NULL;
1869
1870 CHECK_SYMBOL (variable);
1871 sym = XSYMBOL (variable);
1872
1873 start:
1874 switch (sym->redirect)
1875 {
1876 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1877 case SYMBOL_PLAINVAL:
1878 forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1879 if (EQ (valcontents.value, Qunbound))
1880 valcontents.value = Qnil;
1881 break;
1882 case SYMBOL_LOCALIZED:
1883 if (SYMBOL_BLV (sym)->frame_local)
1884 return variable;
1885 else
1886 error ("Symbol %s may not be frame-local",
1887 SDATA (SYMBOL_NAME (variable)));
1888 case SYMBOL_FORWARDED:
1889 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1890 if (KBOARD_OBJFWDP (valcontents.fwd) || BUFFER_OBJFWDP (valcontents.fwd))
1891 error ("Symbol %s may not be frame-local",
1892 SDATA (SYMBOL_NAME (variable)));
1893 break;
1894 default: abort ();
1895 }
1896
1897 if (sym->constant)
1898 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
1899
1900 blv = make_blv (sym, forwarded, valcontents);
1901 blv->frame_local = 1;
1902 sym->redirect = SYMBOL_LOCALIZED;
1903 SET_SYMBOL_BLV (sym, blv);
1904 {
1905 Lisp_Object symbol;
1906 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1907 if (let_shadows_global_binding_p (symbol))
1908 message ("Making %s frame-local while let-bound!",
1909 SDATA (SYMBOL_NAME (variable)));
1910 }
1911 return variable;
1912 }
1913
1914 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1915 1, 2, 0,
1916 doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1917 BUFFER defaults to the current buffer. */)
1918 (variable, buffer)
1919 register Lisp_Object variable, buffer;
1920 {
1921 register struct buffer *buf;
1922 struct Lisp_Symbol *sym;
1923
1924 if (NILP (buffer))
1925 buf = current_buffer;
1926 else
1927 {
1928 CHECK_BUFFER (buffer);
1929 buf = XBUFFER (buffer);
1930 }
1931
1932 CHECK_SYMBOL (variable);
1933 sym = XSYMBOL (variable);
1934
1935 start:
1936 switch (sym->redirect)
1937 {
1938 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1939 case SYMBOL_PLAINVAL: return Qnil;
1940 case SYMBOL_LOCALIZED:
1941 {
1942 Lisp_Object tail, elt, tmp;
1943 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1944 XSETBUFFER (tmp, buf);
1945
1946 for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
1947 {
1948 elt = XCAR (tail);
1949 if (EQ (variable, XCAR (elt)))
1950 {
1951 eassert (!blv->frame_local);
1952 eassert (BLV_FOUND (blv) || !EQ (blv->where, tmp));
1953 return Qt;
1954 }
1955 }
1956 eassert (!BLV_FOUND (blv) || !EQ (blv->where, tmp));
1957 return Qnil;
1958 }
1959 case SYMBOL_FORWARDED:
1960 {
1961 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1962 if (BUFFER_OBJFWDP (valcontents))
1963 {
1964 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1965 int idx = PER_BUFFER_IDX (offset);
1966 if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
1967 return Qt;
1968 }
1969 return Qnil;
1970 }
1971 default: abort ();
1972 }
1973 }
1974
1975 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1976 1, 2, 0,
1977 doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1978 More precisely, this means that setting the variable \(with `set' or`setq'),
1979 while it does not have a `let'-style binding that was made in BUFFER,
1980 will produce a buffer local binding. See Info node
1981 `(elisp)Creating Buffer-Local'.
1982 BUFFER defaults to the current buffer. */)
1983 (variable, buffer)
1984 register Lisp_Object variable, buffer;
1985 {
1986 struct Lisp_Symbol *sym;
1987
1988 CHECK_SYMBOL (variable);
1989 sym = XSYMBOL (variable);
1990
1991 start:
1992 switch (sym->redirect)
1993 {
1994 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1995 case SYMBOL_PLAINVAL: return Qnil;
1996 case SYMBOL_LOCALIZED:
1997 {
1998 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1999 if (blv->local_if_set)
2000 return Qt;
2001 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
2002 return Flocal_variable_p (variable, buffer);
2003 }
2004 case SYMBOL_FORWARDED:
2005 /* All BUFFER_OBJFWD slots become local if they are set. */
2006 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) ? Qt : Qnil);
2007 default: abort ();
2008 }
2009 }
2010
2011 DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
2012 1, 1, 0,
2013 doc: /* Return a value indicating where VARIABLE's current binding comes from.
2014 If the current binding is buffer-local, the value is the current buffer.
2015 If the current binding is frame-local, the value is the selected frame.
2016 If the current binding is global (the default), the value is nil. */)
2017 (variable)
2018 register Lisp_Object variable;
2019 {
2020 struct Lisp_Symbol *sym;
2021
2022 CHECK_SYMBOL (variable);
2023 sym = XSYMBOL (variable);
2024
2025 /* Make sure the current binding is actually swapped in. */
2026 find_symbol_value (variable);
2027
2028 start:
2029 switch (sym->redirect)
2030 {
2031 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
2032 case SYMBOL_PLAINVAL: return Qnil;
2033 case SYMBOL_FORWARDED:
2034 {
2035 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
2036 if (KBOARD_OBJFWDP (valcontents))
2037 return Fframe_terminal (Fselected_frame ());
2038 else if (!BUFFER_OBJFWDP (valcontents))
2039 return Qnil;
2040 }
2041 /* FALLTHROUGH */
2042 case SYMBOL_LOCALIZED:
2043 /* For a local variable, record both the symbol and which
2044 buffer's or frame's value we are saving. */
2045 if (!NILP (Flocal_variable_p (variable, Qnil)))
2046 return Fcurrent_buffer ();
2047 else if (sym->redirect == SYMBOL_LOCALIZED
2048 && BLV_FOUND (SYMBOL_BLV (sym)))
2049 return SYMBOL_BLV (sym)->where;
2050 else
2051 return Qnil;
2052 default: abort ();
2053 }
2054 }
2055
2056 /* This code is disabled now that we use the selected frame to return
2057 keyboard-local-values. */
2058 #if 0
2059 extern struct terminal *get_terminal P_ ((Lisp_Object display, int));
2060
2061 DEFUN ("terminal-local-value", Fterminal_local_value, Sterminal_local_value, 2, 2, 0,
2062 doc: /* Return the terminal-local value of SYMBOL on TERMINAL.
2063 If SYMBOL is not a terminal-local variable, then return its normal
2064 value, like `symbol-value'.
2065
2066 TERMINAL may be a terminal object, a frame, or nil (meaning the
2067 selected frame's terminal device). */)
2068 (symbol, terminal)
2069 Lisp_Object symbol;
2070 Lisp_Object terminal;
2071 {
2072 Lisp_Object result;
2073 struct terminal *t = get_terminal (terminal, 1);
2074 push_kboard (t->kboard);
2075 result = Fsymbol_value (symbol);
2076 pop_kboard ();
2077 return result;
2078 }
2079
2080 DEFUN ("set-terminal-local-value", Fset_terminal_local_value, Sset_terminal_local_value, 3, 3, 0,
2081 doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2082 If VARIABLE is not a terminal-local variable, then set its normal
2083 binding, like `set'.
2084
2085 TERMINAL may be a terminal object, a frame, or nil (meaning the
2086 selected frame's terminal device). */)
2087 (symbol, terminal, value)
2088 Lisp_Object symbol;
2089 Lisp_Object terminal;
2090 Lisp_Object value;
2091 {
2092 Lisp_Object result;
2093 struct terminal *t = get_terminal (terminal, 1);
2094 push_kboard (d->kboard);
2095 result = Fset (symbol, value);
2096 pop_kboard ();
2097 return result;
2098 }
2099 #endif
2100 \f
2101 /* Find the function at the end of a chain of symbol function indirections. */
2102
2103 /* If OBJECT is a symbol, find the end of its function chain and
2104 return the value found there. If OBJECT is not a symbol, just
2105 return it. If there is a cycle in the function chain, signal a
2106 cyclic-function-indirection error.
2107
2108 This is like Findirect_function, except that it doesn't signal an
2109 error if the chain ends up unbound. */
2110 Lisp_Object
2111 indirect_function (object)
2112 register Lisp_Object object;
2113 {
2114 Lisp_Object tortoise, hare;
2115
2116 hare = tortoise = object;
2117
2118 for (;;)
2119 {
2120 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
2121 break;
2122 hare = XSYMBOL (hare)->function;
2123 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
2124 break;
2125 hare = XSYMBOL (hare)->function;
2126
2127 tortoise = XSYMBOL (tortoise)->function;
2128
2129 if (EQ (hare, tortoise))
2130 xsignal1 (Qcyclic_function_indirection, object);
2131 }
2132
2133 return hare;
2134 }
2135
2136 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
2137 doc: /* Return the function at the end of OBJECT's function chain.
2138 If OBJECT is not a symbol, just return it. Otherwise, follow all
2139 function indirections to find the final function binding and return it.
2140 If the final symbol in the chain is unbound, signal a void-function error.
2141 Optional arg NOERROR non-nil means to return nil instead of signalling.
2142 Signal a cyclic-function-indirection error if there is a loop in the
2143 function chain of symbols. */)
2144 (object, noerror)
2145 register Lisp_Object object;
2146 Lisp_Object noerror;
2147 {
2148 Lisp_Object result;
2149
2150 /* Optimize for no indirection. */
2151 result = object;
2152 if (SYMBOLP (result) && !EQ (result, Qunbound)
2153 && (result = XSYMBOL (result)->function, SYMBOLP (result)))
2154 result = indirect_function (result);
2155 if (!EQ (result, Qunbound))
2156 return result;
2157
2158 if (NILP (noerror))
2159 xsignal1 (Qvoid_function, object);
2160
2161 return Qnil;
2162 }
2163 \f
2164 /* Extract and set vector and string elements */
2165
2166 DEFUN ("aref", Faref, Saref, 2, 2, 0,
2167 doc: /* Return the element of ARRAY at index IDX.
2168 ARRAY may be a vector, a string, a char-table, a bool-vector,
2169 or a byte-code object. IDX starts at 0. */)
2170 (array, idx)
2171 register Lisp_Object array;
2172 Lisp_Object idx;
2173 {
2174 register int idxval;
2175
2176 CHECK_NUMBER (idx);
2177 idxval = XINT (idx);
2178 if (STRINGP (array))
2179 {
2180 int c, idxval_byte;
2181
2182 if (idxval < 0 || idxval >= SCHARS (array))
2183 args_out_of_range (array, idx);
2184 if (! STRING_MULTIBYTE (array))
2185 return make_number ((unsigned char) SREF (array, idxval));
2186 idxval_byte = string_char_to_byte (array, idxval);
2187
2188 c = STRING_CHAR (SDATA (array) + idxval_byte);
2189 return make_number (c);
2190 }
2191 else if (BOOL_VECTOR_P (array))
2192 {
2193 int val;
2194
2195 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
2196 args_out_of_range (array, idx);
2197
2198 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
2199 return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil);
2200 }
2201 else if (CHAR_TABLE_P (array))
2202 {
2203 CHECK_CHARACTER (idx);
2204 return CHAR_TABLE_REF (array, idxval);
2205 }
2206 else
2207 {
2208 int size = 0;
2209 if (VECTORP (array))
2210 size = XVECTOR (array)->size;
2211 else if (COMPILEDP (array))
2212 size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
2213 else
2214 wrong_type_argument (Qarrayp, array);
2215
2216 if (idxval < 0 || idxval >= size)
2217 args_out_of_range (array, idx);
2218 return XVECTOR (array)->contents[idxval];
2219 }
2220 }
2221
2222 DEFUN ("aset", Faset, Saset, 3, 3, 0,
2223 doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
2224 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2225 bool-vector. IDX starts at 0. */)
2226 (array, idx, newelt)
2227 register Lisp_Object array;
2228 Lisp_Object idx, newelt;
2229 {
2230 register int idxval;
2231
2232 CHECK_NUMBER (idx);
2233 idxval = XINT (idx);
2234 CHECK_ARRAY (array, Qarrayp);
2235 CHECK_IMPURE (array);
2236
2237 if (VECTORP (array))
2238 {
2239 if (idxval < 0 || idxval >= XVECTOR (array)->size)
2240 args_out_of_range (array, idx);
2241 XVECTOR (array)->contents[idxval] = newelt;
2242 }
2243 else if (BOOL_VECTOR_P (array))
2244 {
2245 int val;
2246
2247 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
2248 args_out_of_range (array, idx);
2249
2250 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
2251
2252 if (! NILP (newelt))
2253 val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR);
2254 else
2255 val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR));
2256 XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val;
2257 }
2258 else if (CHAR_TABLE_P (array))
2259 {
2260 CHECK_CHARACTER (idx);
2261 CHAR_TABLE_SET (array, idxval, newelt);
2262 }
2263 else if (STRING_MULTIBYTE (array))
2264 {
2265 int idxval_byte, prev_bytes, new_bytes, nbytes;
2266 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
2267
2268 if (idxval < 0 || idxval >= SCHARS (array))
2269 args_out_of_range (array, idx);
2270 CHECK_CHARACTER (newelt);
2271
2272 nbytes = SBYTES (array);
2273
2274 idxval_byte = string_char_to_byte (array, idxval);
2275 p1 = SDATA (array) + idxval_byte;
2276 PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes);
2277 new_bytes = CHAR_STRING (XINT (newelt), p0);
2278 if (prev_bytes != new_bytes)
2279 {
2280 /* We must relocate the string data. */
2281 int nchars = SCHARS (array);
2282 unsigned char *str;
2283 USE_SAFE_ALLOCA;
2284
2285 SAFE_ALLOCA (str, unsigned char *, nbytes);
2286 bcopy (SDATA (array), str, nbytes);
2287 allocate_string_data (XSTRING (array), nchars,
2288 nbytes + new_bytes - prev_bytes);
2289 bcopy (str, SDATA (array), idxval_byte);
2290 p1 = SDATA (array) + idxval_byte;
2291 bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
2292 nbytes - (idxval_byte + prev_bytes));
2293 SAFE_FREE ();
2294 clear_string_char_byte_cache ();
2295 }
2296 while (new_bytes--)
2297 *p1++ = *p0++;
2298 }
2299 else
2300 {
2301 if (idxval < 0 || idxval >= SCHARS (array))
2302 args_out_of_range (array, idx);
2303 CHECK_NUMBER (newelt);
2304
2305 if (XINT (newelt) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt)))
2306 {
2307 int i;
2308
2309 for (i = SBYTES (array) - 1; i >= 0; i--)
2310 if (SREF (array, i) >= 0x80)
2311 args_out_of_range (array, newelt);
2312 /* ARRAY is an ASCII string. Convert it to a multibyte
2313 string, and try `aset' again. */
2314 STRING_SET_MULTIBYTE (array);
2315 return Faset (array, idx, newelt);
2316 }
2317 SSET (array, idxval, XINT (newelt));
2318 }
2319
2320 return newelt;
2321 }
2322 \f
2323 /* Arithmetic functions */
2324
2325 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
2326
2327 Lisp_Object
2328 arithcompare (num1, num2, comparison)
2329 Lisp_Object num1, num2;
2330 enum comparison comparison;
2331 {
2332 double f1 = 0, f2 = 0;
2333 int floatp = 0;
2334
2335 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
2336 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
2337
2338 if (FLOATP (num1) || FLOATP (num2))
2339 {
2340 floatp = 1;
2341 f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
2342 f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
2343 }
2344
2345 switch (comparison)
2346 {
2347 case equal:
2348 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
2349 return Qt;
2350 return Qnil;
2351
2352 case notequal:
2353 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
2354 return Qt;
2355 return Qnil;
2356
2357 case less:
2358 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
2359 return Qt;
2360 return Qnil;
2361
2362 case less_or_equal:
2363 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
2364 return Qt;
2365 return Qnil;
2366
2367 case grtr:
2368 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
2369 return Qt;
2370 return Qnil;
2371
2372 case grtr_or_equal:
2373 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
2374 return Qt;
2375 return Qnil;
2376
2377 default:
2378 abort ();
2379 }
2380 }
2381
2382 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
2383 doc: /* Return t if two args, both numbers or markers, are equal. */)
2384 (num1, num2)
2385 register Lisp_Object num1, num2;
2386 {
2387 return arithcompare (num1, num2, equal);
2388 }
2389
2390 DEFUN ("<", Flss, Slss, 2, 2, 0,
2391 doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2392 (num1, num2)
2393 register Lisp_Object num1, num2;
2394 {
2395 return arithcompare (num1, num2, less);
2396 }
2397
2398 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
2399 doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2400 (num1, num2)
2401 register Lisp_Object num1, num2;
2402 {
2403 return arithcompare (num1, num2, grtr);
2404 }
2405
2406 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
2407 doc: /* Return t if first arg is less than or equal to second arg.
2408 Both must be numbers or markers. */)
2409 (num1, num2)
2410 register Lisp_Object num1, num2;
2411 {
2412 return arithcompare (num1, num2, less_or_equal);
2413 }
2414
2415 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
2416 doc: /* Return t if first arg is greater than or equal to second arg.
2417 Both must be numbers or markers. */)
2418 (num1, num2)
2419 register Lisp_Object num1, num2;
2420 {
2421 return arithcompare (num1, num2, grtr_or_equal);
2422 }
2423
2424 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
2425 doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2426 (num1, num2)
2427 register Lisp_Object num1, num2;
2428 {
2429 return arithcompare (num1, num2, notequal);
2430 }
2431
2432 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
2433 doc: /* Return t if NUMBER is zero. */)
2434 (number)
2435 register Lisp_Object number;
2436 {
2437 CHECK_NUMBER_OR_FLOAT (number);
2438
2439 if (FLOATP (number))
2440 {
2441 if (XFLOAT_DATA (number) == 0.0)
2442 return Qt;
2443 return Qnil;
2444 }
2445
2446 if (!XINT (number))
2447 return Qt;
2448 return Qnil;
2449 }
2450 \f
2451 /* Convert between long values and pairs of Lisp integers.
2452 Note that long_to_cons returns a single Lisp integer
2453 when the value fits in one. */
2454
2455 Lisp_Object
2456 long_to_cons (i)
2457 unsigned long i;
2458 {
2459 unsigned long top = i >> 16;
2460 unsigned int bot = i & 0xFFFF;
2461 if (top == 0)
2462 return make_number (bot);
2463 if (top == (unsigned long)-1 >> 16)
2464 return Fcons (make_number (-1), make_number (bot));
2465 return Fcons (make_number (top), make_number (bot));
2466 }
2467
2468 unsigned long
2469 cons_to_long (c)
2470 Lisp_Object c;
2471 {
2472 Lisp_Object top, bot;
2473 if (INTEGERP (c))
2474 return XINT (c);
2475 top = XCAR (c);
2476 bot = XCDR (c);
2477 if (CONSP (bot))
2478 bot = XCAR (bot);
2479 return ((XINT (top) << 16) | XINT (bot));
2480 }
2481 \f
2482 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
2483 doc: /* Return the decimal representation of NUMBER as a string.
2484 Uses a minus sign if negative.
2485 NUMBER may be an integer or a floating point number. */)
2486 (number)
2487 Lisp_Object number;
2488 {
2489 char buffer[VALBITS];
2490
2491 CHECK_NUMBER_OR_FLOAT (number);
2492
2493 if (FLOATP (number))
2494 {
2495 char pigbuf[350]; /* see comments in float_to_string */
2496
2497 float_to_string (pigbuf, XFLOAT_DATA (number));
2498 return build_string (pigbuf);
2499 }
2500
2501 if (sizeof (int) == sizeof (EMACS_INT))
2502 sprintf (buffer, "%d", (int) XINT (number));
2503 else if (sizeof (long) == sizeof (EMACS_INT))
2504 sprintf (buffer, "%ld", (long) XINT (number));
2505 else
2506 abort ();
2507 return build_string (buffer);
2508 }
2509
2510 INLINE static int
2511 digit_to_number (character, base)
2512 int character, base;
2513 {
2514 int digit;
2515
2516 if (character >= '0' && character <= '9')
2517 digit = character - '0';
2518 else if (character >= 'a' && character <= 'z')
2519 digit = character - 'a' + 10;
2520 else if (character >= 'A' && character <= 'Z')
2521 digit = character - 'A' + 10;
2522 else
2523 return -1;
2524
2525 if (digit >= base)
2526 return -1;
2527 else
2528 return digit;
2529 }
2530
2531 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
2532 doc: /* Parse STRING as a decimal number and return the number.
2533 This parses both integers and floating point numbers.
2534 It ignores leading spaces and tabs, and all trailing chars.
2535
2536 If BASE, interpret STRING as a number in that base. If BASE isn't
2537 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2538 If the base used is not 10, STRING is always parsed as integer. */)
2539 (string, base)
2540 register Lisp_Object string, base;
2541 {
2542 register unsigned char *p;
2543 register int b;
2544 int sign = 1;
2545 Lisp_Object val;
2546
2547 CHECK_STRING (string);
2548
2549 if (NILP (base))
2550 b = 10;
2551 else
2552 {
2553 CHECK_NUMBER (base);
2554 b = XINT (base);
2555 if (b < 2 || b > 16)
2556 xsignal1 (Qargs_out_of_range, base);
2557 }
2558
2559 /* Skip any whitespace at the front of the number. Some versions of
2560 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2561 p = SDATA (string);
2562 while (*p == ' ' || *p == '\t')
2563 p++;
2564
2565 if (*p == '-')
2566 {
2567 sign = -1;
2568 p++;
2569 }
2570 else if (*p == '+')
2571 p++;
2572
2573 if (isfloat_string (p, 1) && b == 10)
2574 val = make_float (sign * atof (p));
2575 else
2576 {
2577 double v = 0;
2578
2579 while (1)
2580 {
2581 int digit = digit_to_number (*p++, b);
2582 if (digit < 0)
2583 break;
2584 v = v * b + digit;
2585 }
2586
2587 val = make_fixnum_or_float (sign * v);
2588 }
2589
2590 return val;
2591 }
2592
2593 \f
2594 enum arithop
2595 {
2596 Aadd,
2597 Asub,
2598 Amult,
2599 Adiv,
2600 Alogand,
2601 Alogior,
2602 Alogxor,
2603 Amax,
2604 Amin
2605 };
2606
2607 static Lisp_Object float_arith_driver P_ ((double, int, enum arithop,
2608 int, Lisp_Object *));
2609 extern Lisp_Object fmod_float ();
2610
2611 Lisp_Object
2612 arith_driver (code, nargs, args)
2613 enum arithop code;
2614 int nargs;
2615 register Lisp_Object *args;
2616 {
2617 register Lisp_Object val;
2618 register int argnum;
2619 register EMACS_INT accum = 0;
2620 register EMACS_INT next;
2621
2622 switch (SWITCH_ENUM_CAST (code))
2623 {
2624 case Alogior:
2625 case Alogxor:
2626 case Aadd:
2627 case Asub:
2628 accum = 0;
2629 break;
2630 case Amult:
2631 accum = 1;
2632 break;
2633 case Alogand:
2634 accum = -1;
2635 break;
2636 default:
2637 break;
2638 }
2639
2640 for (argnum = 0; argnum < nargs; argnum++)
2641 {
2642 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2643 val = args[argnum];
2644 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2645
2646 if (FLOATP (val))
2647 return float_arith_driver ((double) accum, argnum, code,
2648 nargs, args);
2649 args[argnum] = val;
2650 next = XINT (args[argnum]);
2651 switch (SWITCH_ENUM_CAST (code))
2652 {
2653 case Aadd:
2654 accum += next;
2655 break;
2656 case Asub:
2657 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2658 break;
2659 case Amult:
2660 accum *= next;
2661 break;
2662 case Adiv:
2663 if (!argnum)
2664 accum = next;
2665 else
2666 {
2667 if (next == 0)
2668 xsignal0 (Qarith_error);
2669 accum /= next;
2670 }
2671 break;
2672 case Alogand:
2673 accum &= next;
2674 break;
2675 case Alogior:
2676 accum |= next;
2677 break;
2678 case Alogxor:
2679 accum ^= next;
2680 break;
2681 case Amax:
2682 if (!argnum || next > accum)
2683 accum = next;
2684 break;
2685 case Amin:
2686 if (!argnum || next < accum)
2687 accum = next;
2688 break;
2689 }
2690 }
2691
2692 XSETINT (val, accum);
2693 return val;
2694 }
2695
2696 #undef isnan
2697 #define isnan(x) ((x) != (x))
2698
2699 static Lisp_Object
2700 float_arith_driver (accum, argnum, code, nargs, args)
2701 double accum;
2702 register int argnum;
2703 enum arithop code;
2704 int nargs;
2705 register Lisp_Object *args;
2706 {
2707 register Lisp_Object val;
2708 double next;
2709
2710 for (; argnum < nargs; argnum++)
2711 {
2712 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2713 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2714
2715 if (FLOATP (val))
2716 {
2717 next = XFLOAT_DATA (val);
2718 }
2719 else
2720 {
2721 args[argnum] = val; /* runs into a compiler bug. */
2722 next = XINT (args[argnum]);
2723 }
2724 switch (SWITCH_ENUM_CAST (code))
2725 {
2726 case Aadd:
2727 accum += next;
2728 break;
2729 case Asub:
2730 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2731 break;
2732 case Amult:
2733 accum *= next;
2734 break;
2735 case Adiv:
2736 if (!argnum)
2737 accum = next;
2738 else
2739 {
2740 if (! IEEE_FLOATING_POINT && next == 0)
2741 xsignal0 (Qarith_error);
2742 accum /= next;
2743 }
2744 break;
2745 case Alogand:
2746 case Alogior:
2747 case Alogxor:
2748 return wrong_type_argument (Qinteger_or_marker_p, val);
2749 case Amax:
2750 if (!argnum || isnan (next) || next > accum)
2751 accum = next;
2752 break;
2753 case Amin:
2754 if (!argnum || isnan (next) || next < accum)
2755 accum = next;
2756 break;
2757 }
2758 }
2759
2760 return make_float (accum);
2761 }
2762
2763
2764 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2765 doc: /* Return sum of any number of arguments, which are numbers or markers.
2766 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2767 (nargs, args)
2768 int nargs;
2769 Lisp_Object *args;
2770 {
2771 return arith_driver (Aadd, nargs, args);
2772 }
2773
2774 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2775 doc: /* Negate number or subtract numbers or markers and return the result.
2776 With one arg, negates it. With more than one arg,
2777 subtracts all but the first from the first.
2778 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2779 (nargs, args)
2780 int nargs;
2781 Lisp_Object *args;
2782 {
2783 return arith_driver (Asub, nargs, args);
2784 }
2785
2786 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2787 doc: /* Return product of any number of arguments, which are numbers or markers.
2788 usage: (* &rest NUMBERS-OR-MARKERS) */)
2789 (nargs, args)
2790 int nargs;
2791 Lisp_Object *args;
2792 {
2793 return arith_driver (Amult, nargs, args);
2794 }
2795
2796 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
2797 doc: /* Return first argument divided by all the remaining arguments.
2798 The arguments must be numbers or markers.
2799 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2800 (nargs, args)
2801 int nargs;
2802 Lisp_Object *args;
2803 {
2804 int argnum;
2805 for (argnum = 2; argnum < nargs; argnum++)
2806 if (FLOATP (args[argnum]))
2807 return float_arith_driver (0, 0, Adiv, nargs, args);
2808 return arith_driver (Adiv, nargs, args);
2809 }
2810
2811 DEFUN ("%", Frem, Srem, 2, 2, 0,
2812 doc: /* Return remainder of X divided by Y.
2813 Both must be integers or markers. */)
2814 (x, y)
2815 register Lisp_Object x, y;
2816 {
2817 Lisp_Object val;
2818
2819 CHECK_NUMBER_COERCE_MARKER (x);
2820 CHECK_NUMBER_COERCE_MARKER (y);
2821
2822 if (XFASTINT (y) == 0)
2823 xsignal0 (Qarith_error);
2824
2825 XSETINT (val, XINT (x) % XINT (y));
2826 return val;
2827 }
2828
2829 #ifndef HAVE_FMOD
2830 double
2831 fmod (f1, f2)
2832 double f1, f2;
2833 {
2834 double r = f1;
2835
2836 if (f2 < 0.0)
2837 f2 = -f2;
2838
2839 /* If the magnitude of the result exceeds that of the divisor, or
2840 the sign of the result does not agree with that of the dividend,
2841 iterate with the reduced value. This does not yield a
2842 particularly accurate result, but at least it will be in the
2843 range promised by fmod. */
2844 do
2845 r -= f2 * floor (r / f2);
2846 while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
2847
2848 return r;
2849 }
2850 #endif /* ! HAVE_FMOD */
2851
2852 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2853 doc: /* Return X modulo Y.
2854 The result falls between zero (inclusive) and Y (exclusive).
2855 Both X and Y must be numbers or markers. */)
2856 (x, y)
2857 register Lisp_Object x, y;
2858 {
2859 Lisp_Object val;
2860 EMACS_INT i1, i2;
2861
2862 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
2863 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
2864
2865 if (FLOATP (x) || FLOATP (y))
2866 return fmod_float (x, y);
2867
2868 i1 = XINT (x);
2869 i2 = XINT (y);
2870
2871 if (i2 == 0)
2872 xsignal0 (Qarith_error);
2873
2874 i1 %= i2;
2875
2876 /* If the "remainder" comes out with the wrong sign, fix it. */
2877 if (i2 < 0 ? i1 > 0 : i1 < 0)
2878 i1 += i2;
2879
2880 XSETINT (val, i1);
2881 return val;
2882 }
2883
2884 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2885 doc: /* Return largest of all the arguments (which must be numbers or markers).
2886 The value is always a number; markers are converted to numbers.
2887 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2888 (nargs, args)
2889 int nargs;
2890 Lisp_Object *args;
2891 {
2892 return arith_driver (Amax, nargs, args);
2893 }
2894
2895 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2896 doc: /* Return smallest of all the arguments (which must be numbers or markers).
2897 The value is always a number; markers are converted to numbers.
2898 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2899 (nargs, args)
2900 int nargs;
2901 Lisp_Object *args;
2902 {
2903 return arith_driver (Amin, nargs, args);
2904 }
2905
2906 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2907 doc: /* Return bitwise-and of all the arguments.
2908 Arguments may be integers, or markers converted to integers.
2909 usage: (logand &rest INTS-OR-MARKERS) */)
2910 (nargs, args)
2911 int nargs;
2912 Lisp_Object *args;
2913 {
2914 return arith_driver (Alogand, nargs, args);
2915 }
2916
2917 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2918 doc: /* Return bitwise-or of all the arguments.
2919 Arguments may be integers, or markers converted to integers.
2920 usage: (logior &rest INTS-OR-MARKERS) */)
2921 (nargs, args)
2922 int nargs;
2923 Lisp_Object *args;
2924 {
2925 return arith_driver (Alogior, nargs, args);
2926 }
2927
2928 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2929 doc: /* Return bitwise-exclusive-or of all the arguments.
2930 Arguments may be integers, or markers converted to integers.
2931 usage: (logxor &rest INTS-OR-MARKERS) */)
2932 (nargs, args)
2933 int nargs;
2934 Lisp_Object *args;
2935 {
2936 return arith_driver (Alogxor, nargs, args);
2937 }
2938
2939 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2940 doc: /* Return VALUE with its bits shifted left by COUNT.
2941 If COUNT is negative, shifting is actually to the right.
2942 In this case, the sign bit is duplicated. */)
2943 (value, count)
2944 register Lisp_Object value, count;
2945 {
2946 register Lisp_Object val;
2947
2948 CHECK_NUMBER (value);
2949 CHECK_NUMBER (count);
2950
2951 if (XINT (count) >= BITS_PER_EMACS_INT)
2952 XSETINT (val, 0);
2953 else if (XINT (count) > 0)
2954 XSETINT (val, XINT (value) << XFASTINT (count));
2955 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2956 XSETINT (val, XINT (value) < 0 ? -1 : 0);
2957 else
2958 XSETINT (val, XINT (value) >> -XINT (count));
2959 return val;
2960 }
2961
2962 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2963 doc: /* Return VALUE with its bits shifted left by COUNT.
2964 If COUNT is negative, shifting is actually to the right.
2965 In this case, zeros are shifted in on the left. */)
2966 (value, count)
2967 register Lisp_Object value, count;
2968 {
2969 register Lisp_Object val;
2970
2971 CHECK_NUMBER (value);
2972 CHECK_NUMBER (count);
2973
2974 if (XINT (count) >= BITS_PER_EMACS_INT)
2975 XSETINT (val, 0);
2976 else if (XINT (count) > 0)
2977 XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
2978 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2979 XSETINT (val, 0);
2980 else
2981 XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
2982 return val;
2983 }
2984
2985 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2986 doc: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2987 Markers are converted to integers. */)
2988 (number)
2989 register Lisp_Object number;
2990 {
2991 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2992
2993 if (FLOATP (number))
2994 return (make_float (1.0 + XFLOAT_DATA (number)));
2995
2996 XSETINT (number, XINT (number) + 1);
2997 return number;
2998 }
2999
3000 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
3001 doc: /* Return NUMBER minus one. NUMBER may be a number or a marker.
3002 Markers are converted to integers. */)
3003 (number)
3004 register Lisp_Object number;
3005 {
3006 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
3007
3008 if (FLOATP (number))
3009 return (make_float (-1.0 + XFLOAT_DATA (number)));
3010
3011 XSETINT (number, XINT (number) - 1);
3012 return number;
3013 }
3014
3015 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
3016 doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
3017 (number)
3018 register Lisp_Object number;
3019 {
3020 CHECK_NUMBER (number);
3021 XSETINT (number, ~XINT (number));
3022 return number;
3023 }
3024
3025 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
3026 doc: /* Return the byteorder for the machine.
3027 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3028 lowercase l) for small endian machines. */)
3029 ()
3030 {
3031 unsigned i = 0x04030201;
3032 int order = *(char *)&i == 1 ? 108 : 66;
3033
3034 return make_number (order);
3035 }
3036
3037
3038 \f
3039 void
3040 syms_of_data ()
3041 {
3042 Lisp_Object error_tail, arith_tail;
3043
3044 Qquote = intern_c_string ("quote");
3045 Qlambda = intern_c_string ("lambda");
3046 Qsubr = intern_c_string ("subr");
3047 Qerror_conditions = intern_c_string ("error-conditions");
3048 Qerror_message = intern_c_string ("error-message");
3049 Qtop_level = intern_c_string ("top-level");
3050
3051 Qerror = intern_c_string ("error");
3052 Qquit = intern_c_string ("quit");
3053 Qwrong_type_argument = intern_c_string ("wrong-type-argument");
3054 Qargs_out_of_range = intern_c_string ("args-out-of-range");
3055 Qvoid_function = intern_c_string ("void-function");
3056 Qcyclic_function_indirection = intern_c_string ("cyclic-function-indirection");
3057 Qcyclic_variable_indirection = intern_c_string ("cyclic-variable-indirection");
3058 Qvoid_variable = intern_c_string ("void-variable");
3059 Qsetting_constant = intern_c_string ("setting-constant");
3060 Qinvalid_read_syntax = intern_c_string ("invalid-read-syntax");
3061
3062 Qinvalid_function = intern_c_string ("invalid-function");
3063 Qwrong_number_of_arguments = intern_c_string ("wrong-number-of-arguments");
3064 Qno_catch = intern_c_string ("no-catch");
3065 Qend_of_file = intern_c_string ("end-of-file");
3066 Qarith_error = intern_c_string ("arith-error");
3067 Qbeginning_of_buffer = intern_c_string ("beginning-of-buffer");
3068 Qend_of_buffer = intern_c_string ("end-of-buffer");
3069 Qbuffer_read_only = intern_c_string ("buffer-read-only");
3070 Qtext_read_only = intern_c_string ("text-read-only");
3071 Qmark_inactive = intern_c_string ("mark-inactive");
3072
3073 Qlistp = intern_c_string ("listp");
3074 Qconsp = intern_c_string ("consp");
3075 Qsymbolp = intern_c_string ("symbolp");
3076 Qkeywordp = intern_c_string ("keywordp");
3077 Qintegerp = intern_c_string ("integerp");
3078 Qnatnump = intern_c_string ("natnump");
3079 Qwholenump = intern_c_string ("wholenump");
3080 Qstringp = intern_c_string ("stringp");
3081 Qarrayp = intern_c_string ("arrayp");
3082 Qsequencep = intern_c_string ("sequencep");
3083 Qbufferp = intern_c_string ("bufferp");
3084 Qvectorp = intern_c_string ("vectorp");
3085 Qchar_or_string_p = intern_c_string ("char-or-string-p");
3086 Qmarkerp = intern_c_string ("markerp");
3087 Qbuffer_or_string_p = intern_c_string ("buffer-or-string-p");
3088 Qinteger_or_marker_p = intern_c_string ("integer-or-marker-p");
3089 Qboundp = intern_c_string ("boundp");
3090 Qfboundp = intern_c_string ("fboundp");
3091
3092 Qfloatp = intern_c_string ("floatp");
3093 Qnumberp = intern_c_string ("numberp");
3094 Qnumber_or_marker_p = intern_c_string ("number-or-marker-p");
3095
3096 Qchar_table_p = intern_c_string ("char-table-p");
3097 Qvector_or_char_table_p = intern_c_string ("vector-or-char-table-p");
3098
3099 Qsubrp = intern_c_string ("subrp");
3100 Qunevalled = intern_c_string ("unevalled");
3101 Qmany = intern_c_string ("many");
3102
3103 Qcdr = intern_c_string ("cdr");
3104
3105 /* Handle automatic advice activation */
3106 Qad_advice_info = intern_c_string ("ad-advice-info");
3107 Qad_activate_internal = intern_c_string ("ad-activate-internal");
3108
3109 error_tail = pure_cons (Qerror, Qnil);
3110
3111 /* ERROR is used as a signaler for random errors for which nothing else is right */
3112
3113 Fput (Qerror, Qerror_conditions,
3114 error_tail);
3115 Fput (Qerror, Qerror_message,
3116 make_pure_c_string ("error"));
3117
3118 Fput (Qquit, Qerror_conditions,
3119 pure_cons (Qquit, Qnil));
3120 Fput (Qquit, Qerror_message,
3121 make_pure_c_string ("Quit"));
3122
3123 Fput (Qwrong_type_argument, Qerror_conditions,
3124 pure_cons (Qwrong_type_argument, error_tail));
3125 Fput (Qwrong_type_argument, Qerror_message,
3126 make_pure_c_string ("Wrong type argument"));
3127
3128 Fput (Qargs_out_of_range, Qerror_conditions,
3129 pure_cons (Qargs_out_of_range, error_tail));
3130 Fput (Qargs_out_of_range, Qerror_message,
3131 make_pure_c_string ("Args out of range"));
3132
3133 Fput (Qvoid_function, Qerror_conditions,
3134 pure_cons (Qvoid_function, error_tail));
3135 Fput (Qvoid_function, Qerror_message,
3136 make_pure_c_string ("Symbol's function definition is void"));
3137
3138 Fput (Qcyclic_function_indirection, Qerror_conditions,
3139 pure_cons (Qcyclic_function_indirection, error_tail));
3140 Fput (Qcyclic_function_indirection, Qerror_message,
3141 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3142
3143 Fput (Qcyclic_variable_indirection, Qerror_conditions,
3144 pure_cons (Qcyclic_variable_indirection, error_tail));
3145 Fput (Qcyclic_variable_indirection, Qerror_message,
3146 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3147
3148 Qcircular_list = intern_c_string ("circular-list");
3149 staticpro (&Qcircular_list);
3150 Fput (Qcircular_list, Qerror_conditions,
3151 pure_cons (Qcircular_list, error_tail));
3152 Fput (Qcircular_list, Qerror_message,
3153 make_pure_c_string ("List contains a loop"));
3154
3155 Fput (Qvoid_variable, Qerror_conditions,
3156 pure_cons (Qvoid_variable, error_tail));
3157 Fput (Qvoid_variable, Qerror_message,
3158 make_pure_c_string ("Symbol's value as variable is void"));
3159
3160 Fput (Qsetting_constant, Qerror_conditions,
3161 pure_cons (Qsetting_constant, error_tail));
3162 Fput (Qsetting_constant, Qerror_message,
3163 make_pure_c_string ("Attempt to set a constant symbol"));
3164
3165 Fput (Qinvalid_read_syntax, Qerror_conditions,
3166 pure_cons (Qinvalid_read_syntax, error_tail));
3167 Fput (Qinvalid_read_syntax, Qerror_message,
3168 make_pure_c_string ("Invalid read syntax"));
3169
3170 Fput (Qinvalid_function, Qerror_conditions,
3171 pure_cons (Qinvalid_function, error_tail));
3172 Fput (Qinvalid_function, Qerror_message,
3173 make_pure_c_string ("Invalid function"));
3174
3175 Fput (Qwrong_number_of_arguments, Qerror_conditions,
3176 pure_cons (Qwrong_number_of_arguments, error_tail));
3177 Fput (Qwrong_number_of_arguments, Qerror_message,
3178 make_pure_c_string ("Wrong number of arguments"));
3179
3180 Fput (Qno_catch, Qerror_conditions,
3181 pure_cons (Qno_catch, error_tail));
3182 Fput (Qno_catch, Qerror_message,
3183 make_pure_c_string ("No catch for tag"));
3184
3185 Fput (Qend_of_file, Qerror_conditions,
3186 pure_cons (Qend_of_file, error_tail));
3187 Fput (Qend_of_file, Qerror_message,
3188 make_pure_c_string ("End of file during parsing"));
3189
3190 arith_tail = pure_cons (Qarith_error, error_tail);
3191 Fput (Qarith_error, Qerror_conditions,
3192 arith_tail);
3193 Fput (Qarith_error, Qerror_message,
3194 make_pure_c_string ("Arithmetic error"));
3195
3196 Fput (Qbeginning_of_buffer, Qerror_conditions,
3197 pure_cons (Qbeginning_of_buffer, error_tail));
3198 Fput (Qbeginning_of_buffer, Qerror_message,
3199 make_pure_c_string ("Beginning of buffer"));
3200
3201 Fput (Qend_of_buffer, Qerror_conditions,
3202 pure_cons (Qend_of_buffer, error_tail));
3203 Fput (Qend_of_buffer, Qerror_message,
3204 make_pure_c_string ("End of buffer"));
3205
3206 Fput (Qbuffer_read_only, Qerror_conditions,
3207 pure_cons (Qbuffer_read_only, error_tail));
3208 Fput (Qbuffer_read_only, Qerror_message,
3209 make_pure_c_string ("Buffer is read-only"));
3210
3211 Fput (Qtext_read_only, Qerror_conditions,
3212 pure_cons (Qtext_read_only, error_tail));
3213 Fput (Qtext_read_only, Qerror_message,
3214 make_pure_c_string ("Text is read-only"));
3215
3216 Qrange_error = intern_c_string ("range-error");
3217 Qdomain_error = intern_c_string ("domain-error");
3218 Qsingularity_error = intern_c_string ("singularity-error");
3219 Qoverflow_error = intern_c_string ("overflow-error");
3220 Qunderflow_error = intern_c_string ("underflow-error");
3221
3222 Fput (Qdomain_error, Qerror_conditions,
3223 pure_cons (Qdomain_error, arith_tail));
3224 Fput (Qdomain_error, Qerror_message,
3225 make_pure_c_string ("Arithmetic domain error"));
3226
3227 Fput (Qrange_error, Qerror_conditions,
3228 pure_cons (Qrange_error, arith_tail));
3229 Fput (Qrange_error, Qerror_message,
3230 make_pure_c_string ("Arithmetic range error"));
3231
3232 Fput (Qsingularity_error, Qerror_conditions,
3233 pure_cons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
3234 Fput (Qsingularity_error, Qerror_message,
3235 make_pure_c_string ("Arithmetic singularity error"));
3236
3237 Fput (Qoverflow_error, Qerror_conditions,
3238 pure_cons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
3239 Fput (Qoverflow_error, Qerror_message,
3240 make_pure_c_string ("Arithmetic overflow error"));
3241
3242 Fput (Qunderflow_error, Qerror_conditions,
3243 pure_cons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
3244 Fput (Qunderflow_error, Qerror_message,
3245 make_pure_c_string ("Arithmetic underflow error"));
3246
3247 staticpro (&Qrange_error);
3248 staticpro (&Qdomain_error);
3249 staticpro (&Qsingularity_error);
3250 staticpro (&Qoverflow_error);
3251 staticpro (&Qunderflow_error);
3252
3253 staticpro (&Qnil);
3254 staticpro (&Qt);
3255 staticpro (&Qquote);
3256 staticpro (&Qlambda);
3257 staticpro (&Qsubr);
3258 staticpro (&Qunbound);
3259 staticpro (&Qerror_conditions);
3260 staticpro (&Qerror_message);
3261 staticpro (&Qtop_level);
3262
3263 staticpro (&Qerror);
3264 staticpro (&Qquit);
3265 staticpro (&Qwrong_type_argument);
3266 staticpro (&Qargs_out_of_range);
3267 staticpro (&Qvoid_function);
3268 staticpro (&Qcyclic_function_indirection);
3269 staticpro (&Qcyclic_variable_indirection);
3270 staticpro (&Qvoid_variable);
3271 staticpro (&Qsetting_constant);
3272 staticpro (&Qinvalid_read_syntax);
3273 staticpro (&Qwrong_number_of_arguments);
3274 staticpro (&Qinvalid_function);
3275 staticpro (&Qno_catch);
3276 staticpro (&Qend_of_file);
3277 staticpro (&Qarith_error);
3278 staticpro (&Qbeginning_of_buffer);
3279 staticpro (&Qend_of_buffer);
3280 staticpro (&Qbuffer_read_only);
3281 staticpro (&Qtext_read_only);
3282 staticpro (&Qmark_inactive);
3283
3284 staticpro (&Qlistp);
3285 staticpro (&Qconsp);
3286 staticpro (&Qsymbolp);
3287 staticpro (&Qkeywordp);
3288 staticpro (&Qintegerp);
3289 staticpro (&Qnatnump);
3290 staticpro (&Qwholenump);
3291 staticpro (&Qstringp);
3292 staticpro (&Qarrayp);
3293 staticpro (&Qsequencep);
3294 staticpro (&Qbufferp);
3295 staticpro (&Qvectorp);
3296 staticpro (&Qchar_or_string_p);
3297 staticpro (&Qmarkerp);
3298 staticpro (&Qbuffer_or_string_p);
3299 staticpro (&Qinteger_or_marker_p);
3300 staticpro (&Qfloatp);
3301 staticpro (&Qnumberp);
3302 staticpro (&Qnumber_or_marker_p);
3303 staticpro (&Qchar_table_p);
3304 staticpro (&Qvector_or_char_table_p);
3305 staticpro (&Qsubrp);
3306 staticpro (&Qmany);
3307 staticpro (&Qunevalled);
3308
3309 staticpro (&Qboundp);
3310 staticpro (&Qfboundp);
3311 staticpro (&Qcdr);
3312 staticpro (&Qad_advice_info);
3313 staticpro (&Qad_activate_internal);
3314
3315 /* Types that type-of returns. */
3316 Qinteger = intern_c_string ("integer");
3317 Qsymbol = intern_c_string ("symbol");
3318 Qstring = intern_c_string ("string");
3319 Qcons = intern_c_string ("cons");
3320 Qmarker = intern_c_string ("marker");
3321 Qoverlay = intern_c_string ("overlay");
3322 Qfloat = intern_c_string ("float");
3323 Qwindow_configuration = intern_c_string ("window-configuration");
3324 Qprocess = intern_c_string ("process");
3325 Qwindow = intern_c_string ("window");
3326 /* Qsubr = intern_c_string ("subr"); */
3327 Qcompiled_function = intern_c_string ("compiled-function");
3328 Qbuffer = intern_c_string ("buffer");
3329 Qframe = intern_c_string ("frame");
3330 Qvector = intern_c_string ("vector");
3331 Qchar_table = intern_c_string ("char-table");
3332 Qbool_vector = intern_c_string ("bool-vector");
3333 Qhash_table = intern_c_string ("hash-table");
3334
3335 DEFSYM (Qfont_spec, "font-spec");
3336 DEFSYM (Qfont_entity, "font-entity");
3337 DEFSYM (Qfont_object, "font-object");
3338
3339 DEFSYM (Qinteractive_form, "interactive-form");
3340
3341 staticpro (&Qinteger);
3342 staticpro (&Qsymbol);
3343 staticpro (&Qstring);
3344 staticpro (&Qcons);
3345 staticpro (&Qmarker);
3346 staticpro (&Qoverlay);
3347 staticpro (&Qfloat);
3348 staticpro (&Qwindow_configuration);
3349 staticpro (&Qprocess);
3350 staticpro (&Qwindow);
3351 /* staticpro (&Qsubr); */
3352 staticpro (&Qcompiled_function);
3353 staticpro (&Qbuffer);
3354 staticpro (&Qframe);
3355 staticpro (&Qvector);
3356 staticpro (&Qchar_table);
3357 staticpro (&Qbool_vector);
3358 staticpro (&Qhash_table);
3359
3360 defsubr (&Sindirect_variable);
3361 defsubr (&Sinteractive_form);
3362 defsubr (&Seq);
3363 defsubr (&Snull);
3364 defsubr (&Stype_of);
3365 defsubr (&Slistp);
3366 defsubr (&Snlistp);
3367 defsubr (&Sconsp);
3368 defsubr (&Satom);
3369 defsubr (&Sintegerp);
3370 defsubr (&Sinteger_or_marker_p);
3371 defsubr (&Snumberp);
3372 defsubr (&Snumber_or_marker_p);
3373 defsubr (&Sfloatp);
3374 defsubr (&Snatnump);
3375 defsubr (&Ssymbolp);
3376 defsubr (&Skeywordp);
3377 defsubr (&Sstringp);
3378 defsubr (&Smultibyte_string_p);
3379 defsubr (&Svectorp);
3380 defsubr (&Schar_table_p);
3381 defsubr (&Svector_or_char_table_p);
3382 defsubr (&Sbool_vector_p);
3383 defsubr (&Sarrayp);
3384 defsubr (&Ssequencep);
3385 defsubr (&Sbufferp);
3386 defsubr (&Smarkerp);
3387 defsubr (&Ssubrp);
3388 defsubr (&Sbyte_code_function_p);
3389 defsubr (&Schar_or_string_p);
3390 defsubr (&Scar);
3391 defsubr (&Scdr);
3392 defsubr (&Scar_safe);
3393 defsubr (&Scdr_safe);
3394 defsubr (&Ssetcar);
3395 defsubr (&Ssetcdr);
3396 defsubr (&Ssymbol_function);
3397 defsubr (&Sindirect_function);
3398 defsubr (&Ssymbol_plist);
3399 defsubr (&Ssymbol_name);
3400 defsubr (&Smakunbound);
3401 defsubr (&Sfmakunbound);
3402 defsubr (&Sboundp);
3403 defsubr (&Sfboundp);
3404 defsubr (&Sfset);
3405 defsubr (&Sdefalias);
3406 defsubr (&Ssetplist);
3407 defsubr (&Ssymbol_value);
3408 defsubr (&Sset);
3409 defsubr (&Sdefault_boundp);
3410 defsubr (&Sdefault_value);
3411 defsubr (&Sset_default);
3412 defsubr (&Ssetq_default);
3413 defsubr (&Smake_variable_buffer_local);
3414 defsubr (&Smake_local_variable);
3415 defsubr (&Skill_local_variable);
3416 defsubr (&Smake_variable_frame_local);
3417 defsubr (&Slocal_variable_p);
3418 defsubr (&Slocal_variable_if_set_p);
3419 defsubr (&Svariable_binding_locus);
3420 #if 0 /* XXX Remove this. --lorentey */
3421 defsubr (&Sterminal_local_value);
3422 defsubr (&Sset_terminal_local_value);
3423 #endif
3424 defsubr (&Saref);
3425 defsubr (&Saset);
3426 defsubr (&Snumber_to_string);
3427 defsubr (&Sstring_to_number);
3428 defsubr (&Seqlsign);
3429 defsubr (&Slss);
3430 defsubr (&Sgtr);
3431 defsubr (&Sleq);
3432 defsubr (&Sgeq);
3433 defsubr (&Sneq);
3434 defsubr (&Szerop);
3435 defsubr (&Splus);
3436 defsubr (&Sminus);
3437 defsubr (&Stimes);
3438 defsubr (&Squo);
3439 defsubr (&Srem);
3440 defsubr (&Smod);
3441 defsubr (&Smax);
3442 defsubr (&Smin);
3443 defsubr (&Slogand);
3444 defsubr (&Slogior);
3445 defsubr (&Slogxor);
3446 defsubr (&Slsh);
3447 defsubr (&Sash);
3448 defsubr (&Sadd1);
3449 defsubr (&Ssub1);
3450 defsubr (&Slognot);
3451 defsubr (&Sbyteorder);
3452 defsubr (&Ssubr_arity);
3453 defsubr (&Ssubr_name);
3454
3455 XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
3456
3457 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum,
3458 doc: /* The largest value that is representable in a Lisp integer. */);
3459 Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
3460 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1;
3461
3462 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum,
3463 doc: /* The smallest value that is representable in a Lisp integer. */);
3464 Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
3465 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1;
3466 }
3467
3468 SIGTYPE
3469 arith_error (signo)
3470 int signo;
3471 {
3472 sigsetmask (SIGEMPTYMASK);
3473
3474 SIGNAL_THREAD_CHECK (signo);
3475 xsignal0 (Qarith_error);
3476 }
3477
3478 void
3479 init_data ()
3480 {
3481 /* Don't do this if just dumping out.
3482 We don't want to call `signal' in this case
3483 so that we don't have trouble with dumping
3484 signal-delivering routines in an inconsistent state. */
3485 #ifndef CANNOT_DUMP
3486 if (!initialized)
3487 return;
3488 #endif /* CANNOT_DUMP */
3489 signal (SIGFPE, arith_error);
3490
3491 #ifdef uts
3492 signal (SIGEMT, arith_error);
3493 #endif /* uts */
3494 }
3495
3496 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3497 (do not change this comment) */