?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Use defcustom for user variables.
[emacs.git] / src / data.c
blobda8f207fb531e8ab3caa923d5c88eea388def326
1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
10
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
20
21
22 #include <signal.h>
23
24 #include <config.h>
25 #include "lisp.h"
26 #include "puresize.h"
27 #include "charset.h"
28
29 #ifndef standalone
30 #include "buffer.h"
31 #include "keyboard.h"
32 #endif
33
34 #include "syssignal.h"
35
36 #ifdef LISP_FLOAT_TYPE
37
38 #ifdef STDC_HEADERS
39 #include <float.h>
40 #include <stdlib.h>
41 #endif
42
43 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
44 #ifndef IEEE_FLOATING_POINT
45 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
46 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
47 #define IEEE_FLOATING_POINT 1
48 #else
49 #define IEEE_FLOATING_POINT 0
50 #endif
51 #endif
52
53 /* Work around a problem that happens because math.h on hpux 7
54 defines two static variables--which, in Emacs, are not really static,
55 because `static' is defined as nothing. The problem is that they are
56 here, in floatfns.c, and in lread.c.
57 These macros prevent the name conflict. */
58 #if defined (HPUX) && !defined (HPUX8)
59 #define _MAXLDBL data_c_maxldbl
60 #define _NMAXLDBL data_c_nmaxldbl
61 #endif
62
63 #include <math.h>
64 #endif /* LISP_FLOAT_TYPE */
65
66 #if !defined (atof)
67 extern double atof ();
68 #endif /* !atof */
69
70 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
71 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
72 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
73 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
74 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
75 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
76 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
77 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
78 Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
79 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
80 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
81 Lisp_Object Qbuffer_or_string_p;
82 Lisp_Object Qboundp, Qfboundp;
83 Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
84
85 Lisp_Object Qcdr;
86 Lisp_Object Qad_advice_info, Qad_activate;
87
88 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
89 Lisp_Object Qoverflow_error, Qunderflow_error;
90
91 #ifdef LISP_FLOAT_TYPE
92 Lisp_Object Qfloatp;
93 Lisp_Object Qnumberp, Qnumber_or_marker_p;
94 #endif
95
96 static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
97 static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
98 Lisp_Object Qprocess;
99 static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
100 static Lisp_Object Qchar_table, Qbool_vector;
101
102 static Lisp_Object swap_in_symval_forwarding ();
103
104 Lisp_Object
105 wrong_type_argument (predicate, value)
106 register Lisp_Object predicate, value;
107 {
108 register Lisp_Object tem;
109 do
110 {
111 if (!EQ (Vmocklisp_arguments, Qt))
112 {
113 if (STRINGP (value) &&
114 (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
115 return Fstring_to_number (value);
116 if (INTEGERP (value) && EQ (predicate, Qstringp))
117 return Fnumber_to_string (value);
118 }
119
120 /* If VALUE is not even a valid Lisp object, abort here
121 where we can get a backtrace showing where it came from. */
122 if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
123 abort ();
124
125 value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
126 tem = call1 (predicate, value);
127 }
128 while (NILP (tem));
129 return value;
130 }
131
132 pure_write_error ()
133 {
134 error ("Attempt to modify read-only object");
135 }
136
137 void
138 args_out_of_range (a1, a2)
139 Lisp_Object a1, a2;
140 {
141 while (1)
142 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
143 }
144
145 void
146 args_out_of_range_3 (a1, a2, a3)
147 Lisp_Object a1, a2, a3;
148 {
149 while (1)
150 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
151 }
152
153 /* On some machines, XINT needs a temporary location.
154 Here it is, in case it is needed. */
155
156 int sign_extend_temp;
157
158 /* On a few machines, XINT can only be done by calling this. */
159
160 int
161 sign_extend_lisp_int (num)
162 EMACS_INT num;
163 {
164 if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
165 return num | (((EMACS_INT) (-1)) << VALBITS);
166 else
167 return num & ((((EMACS_INT) 1) << VALBITS) - 1);
168 }
169 \f
170 /* Data type predicates */
171
172 DEFUN ("eq", Feq, Seq, 2, 2, 0,
173 "T if the two args are the same Lisp object.")
174 (obj1, obj2)
175 Lisp_Object obj1, obj2;
176 {
177 if (EQ (obj1, obj2))
178 return Qt;
179 return Qnil;
180 }
181
182 DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
183 (object)
184 Lisp_Object object;
185 {
186 if (NILP (object))
187 return Qt;
188 return Qnil;
189 }
190
191 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
192 "Return a symbol representing the type of OBJECT.\n\
193 The symbol returned names the object's basic type;\n\
194 for example, (type-of 1) returns `integer'.")
195 (object)
196 Lisp_Object object;
197 {
198 switch (XGCTYPE (object))
199 {
200 case Lisp_Int:
201 return Qinteger;
202
203 case Lisp_Symbol:
204 return Qsymbol;
205
206 case Lisp_String:
207 return Qstring;
208
209 case Lisp_Cons:
210 return Qcons;
211
212 case Lisp_Misc:
213 switch (XMISCTYPE (object))
214 {
215 case Lisp_Misc_Marker:
216 return Qmarker;
217 case Lisp_Misc_Overlay:
218 return Qoverlay;
219 case Lisp_Misc_Float:
220 return Qfloat;
221 }
222 abort ();
223
224 case Lisp_Vectorlike:
225 if (GC_WINDOW_CONFIGURATIONP (object))
226 return Qwindow_configuration;
227 if (GC_PROCESSP (object))
228 return Qprocess;
229 if (GC_WINDOWP (object))
230 return Qwindow;
231 if (GC_SUBRP (object))
232 return Qsubr;
233 if (GC_COMPILEDP (object))
234 return Qcompiled_function;
235 if (GC_BUFFERP (object))
236 return Qbuffer;
237 if (GC_CHAR_TABLE_P (object))
238 return Qchar_table;
239 if (GC_BOOL_VECTOR_P (object))
240 return Qbool_vector;
241 if (GC_FRAMEP (object))
242 return Qframe;
243 return Qvector;
244
245 #ifdef LISP_FLOAT_TYPE
246 case Lisp_Float:
247 return Qfloat;
248 #endif
249
250 default:
251 abort ();
252 }
253 }
254
255 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
256 (object)
257 Lisp_Object object;
258 {
259 if (CONSP (object))
260 return Qt;
261 return Qnil;
262 }
263
264 DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
265 (object)
266 Lisp_Object object;
267 {
268 if (CONSP (object))
269 return Qnil;
270 return Qt;
271 }
272
273 DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
274 (object)
275 Lisp_Object object;
276 {
277 if (CONSP (object) || NILP (object))
278 return Qt;
279 return Qnil;
280 }
281
282 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "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, "T if OBJECT is a symbol.")
292 (object)
293 Lisp_Object object;
294 {
295 if (SYMBOLP (object))
296 return Qt;
297 return Qnil;
298 }
299
300 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
301 (object)
302 Lisp_Object object;
303 {
304 if (VECTORP (object))
305 return Qt;
306 return Qnil;
307 }
308
309 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
310 (object)
311 Lisp_Object object;
312 {
313 if (STRINGP (object))
314 return Qt;
315 return Qnil;
316 }
317
318 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, "T if OBJECT is a char-table.")
319 (object)
320 Lisp_Object object;
321 {
322 if (CHAR_TABLE_P (object))
323 return Qt;
324 return Qnil;
325 }
326
327 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
328 Svector_or_char_table_p, 1, 1, 0,
329 "T if OBJECT is a char-table or vector.")
330 (object)
331 Lisp_Object object;
332 {
333 if (VECTORP (object) || CHAR_TABLE_P (object))
334 return Qt;
335 return Qnil;
336 }
337
338 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "T if OBJECT is a bool-vector.")
339 (object)
340 Lisp_Object object;
341 {
342 if (BOOL_VECTOR_P (object))
343 return Qt;
344 return Qnil;
345 }
346
347 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
348 (object)
349 Lisp_Object object;
350 {
351 if (VECTORP (object) || STRINGP (object))
352 return Qt;
353 return Qnil;
354 }
355
356 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
357 "T if OBJECT is a sequence (list or array).")
358 (object)
359 register Lisp_Object object;
360 {
361 if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
362 || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
363 return Qt;
364 return Qnil;
365 }
366
367 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
368 (object)
369 Lisp_Object object;
370 {
371 if (BUFFERP (object))
372 return Qt;
373 return Qnil;
374 }
375
376 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
377 (object)
378 Lisp_Object object;
379 {
380 if (MARKERP (object))
381 return Qt;
382 return Qnil;
383 }
384
385 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
386 (object)
387 Lisp_Object object;
388 {
389 if (SUBRP (object))
390 return Qt;
391 return Qnil;
392 }
393
394 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
395 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
396 (object)
397 Lisp_Object object;
398 {
399 if (COMPILEDP (object))
400 return Qt;
401 return Qnil;
402 }
403
404 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
405 "T if OBJECT is a character (an integer) or a string.")
406 (object)
407 register Lisp_Object object;
408 {
409 if (INTEGERP (object) || STRINGP (object))
410 return Qt;
411 return Qnil;
412 }
413 \f
414 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is an integer.")
415 (object)
416 Lisp_Object object;
417 {
418 if (INTEGERP (object))
419 return Qt;
420 return Qnil;
421 }
422
423 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
424 "T if OBJECT is an integer or a marker (editor pointer).")
425 (object)
426 register Lisp_Object object;
427 {
428 if (MARKERP (object) || INTEGERP (object))
429 return Qt;
430 return Qnil;
431 }
432
433 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
434 "T if OBJECT is a nonnegative integer.")
435 (object)
436 Lisp_Object object;
437 {
438 if (NATNUMP (object))
439 return Qt;
440 return Qnil;
441 }
442
443 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
444 "T if OBJECT is a number (floating point or integer).")
445 (object)
446 Lisp_Object object;
447 {
448 if (NUMBERP (object))
449 return Qt;
450 else
451 return Qnil;
452 }
453
454 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
455 Snumber_or_marker_p, 1, 1, 0,
456 "T if OBJECT is a number or a marker.")
457 (object)
458 Lisp_Object object;
459 {
460 if (NUMBERP (object) || MARKERP (object))
461 return Qt;
462 return Qnil;
463 }
464
465 #ifdef LISP_FLOAT_TYPE
466 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
467 "T if OBJECT is a floating point number.")
468 (object)
469 Lisp_Object object;
470 {
471 if (FLOATP (object))
472 return Qt;
473 return Qnil;
474 }
475 #endif /* LISP_FLOAT_TYPE */
476 \f
477 /* Extract and set components of lists */
478
479 DEFUN ("car", Fcar, Scar, 1, 1, 0,
480 "Return the car of LIST. If arg is nil, return nil.\n\
481 Error if arg is not nil and not a cons cell. See also `car-safe'.")
482 (list)
483 register Lisp_Object list;
484 {
485 while (1)
486 {
487 if (CONSP (list))
488 return XCONS (list)->car;
489 else if (EQ (list, Qnil))
490 return Qnil;
491 else
492 list = wrong_type_argument (Qlistp, list);
493 }
494 }
495
496 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
497 "Return the car of OBJECT if it is a cons cell, or else nil.")
498 (object)
499 Lisp_Object object;
500 {
501 if (CONSP (object))
502 return XCONS (object)->car;
503 else
504 return Qnil;
505 }
506
507 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
508 "Return the cdr of LIST. If arg is nil, return nil.\n\
509 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
510
511 (list)
512 register Lisp_Object list;
513 {
514 while (1)
515 {
516 if (CONSP (list))
517 return XCONS (list)->cdr;
518 else if (EQ (list, Qnil))
519 return Qnil;
520 else
521 list = wrong_type_argument (Qlistp, list);
522 }
523 }
524
525 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
526 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
527 (object)
528 Lisp_Object object;
529 {
530 if (CONSP (object))
531 return XCONS (object)->cdr;
532 else
533 return Qnil;
534 }
535
536 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
537 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
538 (cell, newcar)
539 register Lisp_Object cell, newcar;
540 {
541 if (!CONSP (cell))
542 cell = wrong_type_argument (Qconsp, cell);
543
544 CHECK_IMPURE (cell);
545 XCONS (cell)->car = newcar;
546 return newcar;
547 }
548
549 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
550 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
551 (cell, newcdr)
552 register Lisp_Object cell, newcdr;
553 {
554 if (!CONSP (cell))
555 cell = wrong_type_argument (Qconsp, cell);
556
557 CHECK_IMPURE (cell);
558 XCONS (cell)->cdr = newcdr;
559 return newcdr;
560 }
561 \f
562 /* Extract and set components of symbols */
563
564 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
565 (symbol)
566 register Lisp_Object symbol;
567 {
568 Lisp_Object valcontents;
569 CHECK_SYMBOL (symbol, 0);
570
571 valcontents = XSYMBOL (symbol)->value;
572
573 if (BUFFER_LOCAL_VALUEP (valcontents)
574 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
575 valcontents = swap_in_symval_forwarding (symbol, valcontents);
576
577 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
578 }
579
580 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
581 (symbol)
582 register Lisp_Object symbol;
583 {
584 CHECK_SYMBOL (symbol, 0);
585 return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
586 }
587
588 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
589 (symbol)
590 register Lisp_Object symbol;
591 {
592 CHECK_SYMBOL (symbol, 0);
593 if (NILP (symbol) || EQ (symbol, Qt))
594 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
595 Fset (symbol, Qunbound);
596 return symbol;
597 }
598
599 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
600 (symbol)
601 register Lisp_Object symbol;
602 {
603 CHECK_SYMBOL (symbol, 0);
604 if (NILP (symbol) || EQ (symbol, Qt))
605 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
606 XSYMBOL (symbol)->function = Qunbound;
607 return symbol;
608 }
609
610 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
611 "Return SYMBOL's function definition. Error if that is void.")
612 (symbol)
613 register Lisp_Object symbol;
614 {
615 CHECK_SYMBOL (symbol, 0);
616 if (EQ (XSYMBOL (symbol)->function, Qunbound))
617 return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
618 return XSYMBOL (symbol)->function;
619 }
620
621 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
622 (symbol)
623 register Lisp_Object symbol;
624 {
625 CHECK_SYMBOL (symbol, 0);
626 return XSYMBOL (symbol)->plist;
627 }
628
629 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
630 (symbol)
631 register Lisp_Object symbol;
632 {
633 register Lisp_Object name;
634
635 CHECK_SYMBOL (symbol, 0);
636 XSETSTRING (name, XSYMBOL (symbol)->name);
637 return name;
638 }
639
640 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
641 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
642 (symbol, definition)
643 register Lisp_Object symbol, definition;
644 {
645 CHECK_SYMBOL (symbol, 0);
646 if (NILP (symbol) || EQ (symbol, Qt))
647 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
648 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
649 Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
650 Vautoload_queue);
651 XSYMBOL (symbol)->function = definition;
652 /* Handle automatic advice activation */
653 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
654 {
655 call2 (Qad_activate, symbol, Qnil);
656 definition = XSYMBOL (symbol)->function;
657 }
658 return definition;
659 }
660
661 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
662 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
663 Associates the function with the current load file, if any.")
664 (symbol, definition)
665 register Lisp_Object symbol, definition;
666 {
667 CHECK_SYMBOL (symbol, 0);
668 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
669 Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
670 Vautoload_queue);
671 XSYMBOL (symbol)->function = definition;
672 /* Handle automatic advice activation */
673 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
674 {
675 call2 (Qad_activate, symbol, Qnil);
676 definition = XSYMBOL (symbol)->function;
677 }
678 LOADHIST_ATTACH (symbol);
679 return definition;
680 }
681
682 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
683 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
684 (symbol, newplist)
685 register Lisp_Object symbol, newplist;
686 {
687 CHECK_SYMBOL (symbol, 0);
688 XSYMBOL (symbol)->plist = newplist;
689 return newplist;
690 }
691
692 \f
693 /* Getting and setting values of symbols */
694
695 /* Given the raw contents of a symbol value cell,
696 return the Lisp value of the symbol.
697 This does not handle buffer-local variables; use
698 swap_in_symval_forwarding for that. */
699
700 Lisp_Object
701 do_symval_forwarding (valcontents)
702 register Lisp_Object valcontents;
703 {
704 register Lisp_Object val;
705 int offset;
706 if (MISCP (valcontents))
707 switch (XMISCTYPE (valcontents))
708 {
709 case Lisp_Misc_Intfwd:
710 XSETINT (val, *XINTFWD (valcontents)->intvar);
711 return val;
712
713 case Lisp_Misc_Boolfwd:
714 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
715
716 case Lisp_Misc_Objfwd:
717 return *XOBJFWD (valcontents)->objvar;
718
719 case Lisp_Misc_Buffer_Objfwd:
720 offset = XBUFFER_OBJFWD (valcontents)->offset;
721 return *(Lisp_Object *)(offset + (char *)current_buffer);
722
723 case Lisp_Misc_Kboard_Objfwd:
724 offset = XKBOARD_OBJFWD (valcontents)->offset;
725 return *(Lisp_Object *)(offset + (char *)current_kboard);
726 }
727 return valcontents;
728 }
729
730 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
731 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
732 buffer-independent contents of the value cell: forwarded just one
733 step past the buffer-localness. */
734
735 void
736 store_symval_forwarding (symbol, valcontents, newval)
737 Lisp_Object symbol;
738 register Lisp_Object valcontents, newval;
739 {
740 switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
741 {
742 case Lisp_Misc:
743 switch (XMISCTYPE (valcontents))
744 {
745 case Lisp_Misc_Intfwd:
746 CHECK_NUMBER (newval, 1);
747 *XINTFWD (valcontents)->intvar = XINT (newval);
748 if (*XINTFWD (valcontents)->intvar != XINT (newval))
749 error ("Value out of range for variable `%s'",
750 XSYMBOL (symbol)->name->data);
751 break;
752
753 case Lisp_Misc_Boolfwd:
754 *XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1;
755 break;
756
757 case Lisp_Misc_Objfwd:
758 *XOBJFWD (valcontents)->objvar = newval;
759 break;
760
761 case Lisp_Misc_Buffer_Objfwd:
762 {
763 int offset = XBUFFER_OBJFWD (valcontents)->offset;
764 Lisp_Object type;
765
766 type = *(Lisp_Object *)(offset + (char *)&buffer_local_types);
767 if (! NILP (type) && ! NILP (newval)
768 && XTYPE (newval) != XINT (type))
769 buffer_slot_type_mismatch (offset);
770
771 *(Lisp_Object *)(offset + (char *)current_buffer) = newval;
772 }
773 break;
774
775 case Lisp_Misc_Kboard_Objfwd:
776 (*(Lisp_Object *)((char *)current_kboard
777 + XKBOARD_OBJFWD (valcontents)->offset))
778 = newval;
779 break;
780
781 default:
782 goto def;
783 }
784 break;
785
786 default:
787 def:
788 valcontents = XSYMBOL (symbol)->value;
789 if (BUFFER_LOCAL_VALUEP (valcontents)
790 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
791 XBUFFER_LOCAL_VALUE (valcontents)->car = newval;
792 else
793 XSYMBOL (symbol)->value = newval;
794 }
795 }
796
797 /* Set up the buffer-local symbol SYMBOL for validity in the current
798 buffer. VALCONTENTS is the contents of its value cell.
799 Return the value forwarded one step past the buffer-local indicator. */
800
801 static Lisp_Object
802 swap_in_symval_forwarding (symbol, valcontents)
803 Lisp_Object symbol, valcontents;
804 {
805 /* valcontents is a pointer to a struct resembling the cons
806 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
807
808 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
809 local_var_alist, that being the element whose car is this
810 variable. Or it can be a pointer to the
811 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
812 an element in its alist for this variable.
813
814 If the current buffer is not BUFFER, we store the current
815 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
816 appropriate alist element for the buffer now current and set up
817 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
818 element, and store into BUFFER.
819
820 Note that REALVALUE can be a forwarding pointer. */
821
822 register Lisp_Object tem1;
823 tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
824
825 if (NILP (tem1) || current_buffer != XBUFFER (tem1))
826 {
827 tem1 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
828 Fsetcdr (tem1,
829 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
830 tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
831 if (NILP (tem1))
832 tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
833 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car = tem1;
834 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
835 current_buffer);
836 store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
837 Fcdr (tem1));
838 }
839 return XBUFFER_LOCAL_VALUE (valcontents)->car;
840 }
841 \f
842 /* Find the value of a symbol, returning Qunbound if it's not bound.
843 This is helpful for code which just wants to get a variable's value
844 if it has one, without signaling an error.
845 Note that it must not be possible to quit
846 within this function. Great care is required for this. */
847
848 Lisp_Object
849 find_symbol_value (symbol)
850 Lisp_Object symbol;
851 {
852 register Lisp_Object valcontents, tem1;
853 register Lisp_Object val;
854 CHECK_SYMBOL (symbol, 0);
855 valcontents = XSYMBOL (symbol)->value;
856
857 if (BUFFER_LOCAL_VALUEP (valcontents)
858 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
859 valcontents = swap_in_symval_forwarding (symbol, valcontents);
860
861 if (MISCP (valcontents))
862 {
863 switch (XMISCTYPE (valcontents))
864 {
865 case Lisp_Misc_Intfwd:
866 XSETINT (val, *XINTFWD (valcontents)->intvar);
867 return val;
868
869 case Lisp_Misc_Boolfwd:
870 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
871
872 case Lisp_Misc_Objfwd:
873 return *XOBJFWD (valcontents)->objvar;
874
875 case Lisp_Misc_Buffer_Objfwd:
876 return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
877 + (char *)current_buffer);
878
879 case Lisp_Misc_Kboard_Objfwd:
880 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
881 + (char *)current_kboard);
882 }
883 }
884
885 return valcontents;
886 }
887
888 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
889 "Return SYMBOL's value. Error if that is void.")
890 (symbol)
891 Lisp_Object symbol;
892 {
893 Lisp_Object val;
894
895 val = find_symbol_value (symbol);
896 if (EQ (val, Qunbound))
897 return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
898 else
899 return val;
900 }
901
902 DEFUN ("set", Fset, Sset, 2, 2, 0,
903 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
904 (symbol, newval)
905 register Lisp_Object symbol, newval;
906 {
907 return set_internal (symbol, newval, 0);
908 }
909
910 /* Stpre the value NEWVAL into SYMBOL.
911 If BINDFLAG is zero, then if this symbol is supposed to become
912 local in every buffer where it is set, then we make it local.
913 If BINDFLAG is nonzero, we don't do that. */
914
915 Lisp_Object
916 set_internal (symbol, newval, bindflag)
917 register Lisp_Object symbol, newval;
918 int bindflag;
919 {
920 int voide = EQ (newval, Qunbound);
921
922 register Lisp_Object valcontents, tem1, current_alist_element;
923
924 CHECK_SYMBOL (symbol, 0);
925 if (NILP (symbol) || EQ (symbol, Qt))
926 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
927 valcontents = XSYMBOL (symbol)->value;
928
929 if (BUFFER_OBJFWDP (valcontents))
930 {
931 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
932 register int mask = XINT (*((Lisp_Object *)
933 (idx + (char *)&buffer_local_flags)));
934 if (mask > 0)
935 current_buffer->local_var_flags |= mask;
936 }
937
938 else if (BUFFER_LOCAL_VALUEP (valcontents)
939 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
940 {
941 /* valcontents is actually a pointer to a struct resembling a cons,
942 with contents something like:
943 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
944
945 BUFFER is the last buffer for which this symbol's value was
946 made up to date.
947
948 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
949 local_var_alist, that being the element whose car is this
950 variable. Or it can be a pointer to the
951 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
952 have an element in its alist for this variable (that is, if
953 BUFFER sees the default value of this variable).
954
955 If we want to examine or set the value and BUFFER is current,
956 we just examine or set REALVALUE. If BUFFER is not current, we
957 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
958 then find the appropriate alist element for the buffer now
959 current and set up CURRENT-ALIST-ELEMENT. Then we set
960 REALVALUE out of that element, and store into BUFFER.
961
962 If we are setting the variable and the current buffer does
963 not have an alist entry for this variable, an alist entry is
964 created.
965
966 Note that REALVALUE can be a forwarding pointer. Each time
967 it is examined or set, forwarding must be done. */
968
969 /* What value are we caching right now? */
970 current_alist_element =
971 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
972
973 /* If the current buffer is not the buffer whose binding is
974 currently cached, or if it's a Lisp_Buffer_Local_Value and
975 we're looking at the default value, the cache is invalid; we
976 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
977 if ((current_buffer
978 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car))
979 || (BUFFER_LOCAL_VALUEP (valcontents)
980 && EQ (XCONS (current_alist_element)->car,
981 current_alist_element)))
982 {
983 /* Write out the cached value for the old buffer; copy it
984 back to its alist element. This works if the current
985 buffer only sees the default value, too. */
986 Fsetcdr (current_alist_element,
987 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
988
989 /* Find the new value for CURRENT-ALIST-ELEMENT. */
990 tem1 = Fassq (symbol, current_buffer->local_var_alist);
991 if (NILP (tem1))
992 {
993 /* This buffer still sees the default value. */
994
995 /* If the variable is a Lisp_Some_Buffer_Local_Value,
996 or if this is `let' rather than `set',
997 make CURRENT-ALIST-ELEMENT point to itself,
998 indicating that we're seeing the default value. */
999 if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1000 tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
1001
1002 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1003 give this buffer a new assoc for a local value and set
1004 CURRENT-ALIST-ELEMENT to point to that. */
1005 else
1006 {
1007 tem1 = Fcons (symbol, Fcdr (current_alist_element));
1008 current_buffer->local_var_alist =
1009 Fcons (tem1, current_buffer->local_var_alist);
1010 }
1011 }
1012 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1013 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car
1014 = tem1;
1015
1016 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1017 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
1018 current_buffer);
1019 }
1020 valcontents = XBUFFER_LOCAL_VALUE (valcontents)->car;
1021 }
1022
1023 /* If storing void (making the symbol void), forward only through
1024 buffer-local indicator, not through Lisp_Objfwd, etc. */
1025 if (voide)
1026 store_symval_forwarding (symbol, Qnil, newval);
1027 else
1028 store_symval_forwarding (symbol, valcontents, newval);
1029
1030 return newval;
1031 }
1032 \f
1033 /* Access or set a buffer-local symbol's default value. */
1034
1035 /* Return the default value of SYMBOL, but don't check for voidness.
1036 Return Qunbound if it is void. */
1037
1038 Lisp_Object
1039 default_value (symbol)
1040 Lisp_Object symbol;
1041 {
1042 register Lisp_Object valcontents;
1043
1044 CHECK_SYMBOL (symbol, 0);
1045 valcontents = XSYMBOL (symbol)->value;
1046
1047 /* For a built-in buffer-local variable, get the default value
1048 rather than letting do_symval_forwarding get the current value. */
1049 if (BUFFER_OBJFWDP (valcontents))
1050 {
1051 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1052
1053 if (XINT (*(Lisp_Object *) (idx + (char *) &buffer_local_flags)) != 0)
1054 return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1055 }
1056
1057 /* Handle user-created local variables. */
1058 if (BUFFER_LOCAL_VALUEP (valcontents)
1059 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1060 {
1061 /* If var is set up for a buffer that lacks a local value for it,
1062 the current value is nominally the default value.
1063 But the current value slot may be more up to date, since
1064 ordinary setq stores just that slot. So use that. */
1065 Lisp_Object current_alist_element, alist_element_car;
1066 current_alist_element
1067 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
1068 alist_element_car = XCONS (current_alist_element)->car;
1069 if (EQ (alist_element_car, current_alist_element))
1070 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car);
1071 else
1072 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr;
1073 }
1074 /* For other variables, get the current value. */
1075 return do_symval_forwarding (valcontents);
1076 }
1077
1078 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1079 "Return T if SYMBOL has a non-void default value.\n\
1080 This is the value that is seen in buffers that do not have their own values\n\
1081 for this variable.")
1082 (symbol)
1083 Lisp_Object symbol;
1084 {
1085 register Lisp_Object value;
1086
1087 value = default_value (symbol);
1088 return (EQ (value, Qunbound) ? Qnil : Qt);
1089 }
1090
1091 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1092 "Return SYMBOL's default value.\n\
1093 This is the value that is seen in buffers that do not have their own values\n\
1094 for this variable. The default value is meaningful for variables with\n\
1095 local bindings in certain buffers.")
1096 (symbol)
1097 Lisp_Object symbol;
1098 {
1099 register Lisp_Object value;
1100
1101 value = default_value (symbol);
1102 if (EQ (value, Qunbound))
1103 return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
1104 return value;
1105 }
1106
1107 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1108 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1109 The default value is seen in buffers that do not have their own values\n\
1110 for this variable.")
1111 (symbol, value)
1112 Lisp_Object symbol, value;
1113 {
1114 register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
1115
1116 CHECK_SYMBOL (symbol, 0);
1117 valcontents = XSYMBOL (symbol)->value;
1118
1119 /* Handle variables like case-fold-search that have special slots
1120 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1121 variables. */
1122 if (BUFFER_OBJFWDP (valcontents))
1123 {
1124 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1125 register struct buffer *b;
1126 register int mask = XINT (*((Lisp_Object *)
1127 (idx + (char *)&buffer_local_flags)));
1128
1129 if (mask > 0)
1130 {
1131 *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
1132 for (b = all_buffers; b; b = b->next)
1133 if (!(b->local_var_flags & mask))
1134 *(Lisp_Object *)(idx + (char *) b) = value;
1135 }
1136 return value;
1137 }
1138
1139 if (!BUFFER_LOCAL_VALUEP (valcontents)
1140 && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1141 return Fset (symbol, value);
1142
1143 /* Store new value into the DEFAULT-VALUE slot */
1144 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr = value;
1145
1146 /* If that slot is current, we must set the REALVALUE slot too */
1147 current_alist_element
1148 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
1149 alist_element_buffer = Fcar (current_alist_element);
1150 if (EQ (alist_element_buffer, current_alist_element))
1151 store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
1152 value);
1153
1154 return value;
1155 }
1156
1157 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
1158 "Set the default value of variable VAR to VALUE.\n\
1159 VAR, the variable name, is literal (not evaluated);\n\
1160 VALUE is an expression and it is evaluated.\n\
1161 The default value of a variable is seen in buffers\n\
1162 that do not have their own values for the variable.\n\
1163 \n\
1164 More generally, you can use multiple variables and values, as in\n\
1165 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1166 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1167 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1168 of previous SYMs.")
1169 (args)
1170 Lisp_Object args;
1171 {
1172 register Lisp_Object args_left;
1173 register Lisp_Object val, symbol;
1174 struct gcpro gcpro1;
1175
1176 if (NILP (args))
1177 return Qnil;
1178
1179 args_left = args;
1180 GCPRO1 (args);
1181
1182 do
1183 {
1184 val = Feval (Fcar (Fcdr (args_left)));
1185 symbol = Fcar (args_left);
1186 Fset_default (symbol, val);
1187 args_left = Fcdr (Fcdr (args_left));
1188 }
1189 while (!NILP (args_left));
1190
1191 UNGCPRO;
1192 return val;
1193 }
1194 \f
1195 /* Lisp functions for creating and removing buffer-local variables. */
1196
1197 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1198 1, 1, "vMake Variable Buffer Local: ",
1199 "Make VARIABLE have a separate value for each buffer.\n\
1200 At any time, the value for the current buffer is in effect.\n\
1201 There is also a default value which is seen in any buffer which has not yet\n\
1202 set its own value.\n\
1203 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1204 for the current buffer if it was previously using the default value.\n\
1205 The function `default-value' gets the default value and `set-default' sets it.")
1206 (variable)
1207 register Lisp_Object variable;
1208 {
1209 register Lisp_Object tem, valcontents, newval;
1210
1211 CHECK_SYMBOL (variable, 0);
1212
1213 valcontents = XSYMBOL (variable)->value;
1214 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1215 error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1216
1217 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1218 return variable;
1219 if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1220 {
1221 XMISCTYPE (XSYMBOL (variable)->value) = Lisp_Misc_Buffer_Local_Value;
1222 return variable;
1223 }
1224 if (EQ (valcontents, Qunbound))
1225 XSYMBOL (variable)->value = Qnil;
1226 tem = Fcons (Qnil, Fsymbol_value (variable));
1227 XCONS (tem)->car = tem;
1228 newval = allocate_misc ();
1229 XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
1230 XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
1231 XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Fcurrent_buffer (), tem);
1232 XSYMBOL (variable)->value = newval;
1233 return variable;
1234 }
1235
1236 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1237 1, 1, "vMake Local Variable: ",
1238 "Make VARIABLE have a separate value in the current buffer.\n\
1239 Other buffers will continue to share a common default value.\n\
1240 \(The buffer-local value of VARIABLE starts out as the same value\n\
1241 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1242 See also `make-variable-buffer-local'.\n\n\
1243 If the variable is already arranged to become local when set,\n\
1244 this function causes a local value to exist for this buffer,\n\
1245 just as setting the variable would do.\n\
1246 \n\
1247 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1248 Use `make-local-hook' instead.")
1249 (variable)
1250 register Lisp_Object variable;
1251 {
1252 register Lisp_Object tem, valcontents;
1253
1254 CHECK_SYMBOL (variable, 0);
1255
1256 valcontents = XSYMBOL (variable)->value;
1257 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1258 error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1259
1260 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1261 {
1262 tem = Fboundp (variable);
1263
1264 /* Make sure the symbol has a local value in this particular buffer,
1265 by setting it to the same value it already has. */
1266 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1267 return variable;
1268 }
1269 /* Make sure symbol is set up to hold per-buffer values */
1270 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents))
1271 {
1272 Lisp_Object newval;
1273 tem = Fcons (Qnil, do_symval_forwarding (valcontents));
1274 XCONS (tem)->car = tem;
1275 newval = allocate_misc ();
1276 XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
1277 XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
1278 XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Qnil, tem);
1279 XSYMBOL (variable)->value = newval;
1280 }
1281 /* Make sure this buffer has its own value of symbol */
1282 tem = Fassq (variable, current_buffer->local_var_alist);
1283 if (NILP (tem))
1284 {
1285 /* Swap out any local binding for some other buffer, and make
1286 sure the current value is permanently recorded, if it's the
1287 default value. */
1288 find_symbol_value (variable);
1289
1290 current_buffer->local_var_alist
1291 = Fcons (Fcons (variable, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->cdr)->cdr)->cdr),
1292 current_buffer->local_var_alist);
1293
1294 /* Make sure symbol does not think it is set up for this buffer;
1295 force it to look once again for this buffer's value */
1296 {
1297 Lisp_Object *pvalbuf;
1298
1299 valcontents = XSYMBOL (variable)->value;
1300
1301 pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
1302 if (current_buffer == XBUFFER (*pvalbuf))
1303 *pvalbuf = Qnil;
1304 }
1305 }
1306
1307 /* If the symbol forwards into a C variable, then swap in the
1308 variable for this buffer immediately. If C code modifies the
1309 variable before we swap in, then that new value will clobber the
1310 default value the next time we swap. */
1311 valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->car;
1312 if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
1313 swap_in_symval_forwarding (variable, XSYMBOL (variable)->value);
1314
1315 return variable;
1316 }
1317
1318 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1319 1, 1, "vKill Local Variable: ",
1320 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1321 From now on the default value will apply in this buffer.")
1322 (variable)
1323 register Lisp_Object variable;
1324 {
1325 register Lisp_Object tem, valcontents;
1326
1327 CHECK_SYMBOL (variable, 0);
1328
1329 valcontents = XSYMBOL (variable)->value;
1330
1331 if (BUFFER_OBJFWDP (valcontents))
1332 {
1333 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1334 register int mask = XINT (*((Lisp_Object*)
1335 (idx + (char *)&buffer_local_flags)));
1336
1337 if (mask > 0)
1338 {
1339 *(Lisp_Object *)(idx + (char *) current_buffer)
1340 = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1341 current_buffer->local_var_flags &= ~mask;
1342 }
1343 return variable;
1344 }
1345
1346 if (!BUFFER_LOCAL_VALUEP (valcontents)
1347 && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1348 return variable;
1349
1350 /* Get rid of this buffer's alist element, if any */
1351
1352 tem = Fassq (variable, current_buffer->local_var_alist);
1353 if (!NILP (tem))
1354 current_buffer->local_var_alist
1355 = Fdelq (tem, current_buffer->local_var_alist);
1356
1357 /* If the symbol is set up for the current buffer, recompute its
1358 value. We have to do it now, or else forwarded objects won't
1359 work right. */
1360 {
1361 Lisp_Object *pvalbuf;
1362 valcontents = XSYMBOL (variable)->value;
1363 pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
1364 if (current_buffer == XBUFFER (*pvalbuf))
1365 {
1366 *pvalbuf = Qnil;
1367 find_symbol_value (variable);
1368 }
1369 }
1370
1371 return variable;
1372 }
1373
1374 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1375 1, 2, 0,
1376 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1377 BUFFER defaults to the current buffer.")
1378 (variable, buffer)
1379 register Lisp_Object variable, buffer;
1380 {
1381 Lisp_Object valcontents;
1382 register struct buffer *buf;
1383
1384 if (NILP (buffer))
1385 buf = current_buffer;
1386 else
1387 {
1388 CHECK_BUFFER (buffer, 0);
1389 buf = XBUFFER (buffer);
1390 }
1391
1392 CHECK_SYMBOL (variable, 0);
1393
1394 valcontents = XSYMBOL (variable)->value;
1395 if (BUFFER_LOCAL_VALUEP (valcontents)
1396 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1397 {
1398 Lisp_Object tail, elt;
1399 for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
1400 {
1401 elt = XCONS (tail)->car;
1402 if (EQ (variable, XCONS (elt)->car))
1403 return Qt;
1404 }
1405 }
1406 if (BUFFER_OBJFWDP (valcontents))
1407 {
1408 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1409 int mask = XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags));
1410 if (mask == -1 || (buf->local_var_flags & mask))
1411 return Qt;
1412 }
1413 return Qnil;
1414 }
1415
1416 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1417 1, 2, 0,
1418 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1419 BUFFER defaults to the current buffer.")
1420 (variable, buffer)
1421 register Lisp_Object variable, buffer;
1422 {
1423 Lisp_Object valcontents;
1424 register struct buffer *buf;
1425
1426 if (NILP (buffer))
1427 buf = current_buffer;
1428 else
1429 {
1430 CHECK_BUFFER (buffer, 0);
1431 buf = XBUFFER (buffer);
1432 }
1433
1434 CHECK_SYMBOL (variable, 0);
1435
1436 valcontents = XSYMBOL (variable)->value;
1437
1438 /* This means that make-variable-buffer-local was done. */
1439 if (BUFFER_LOCAL_VALUEP (valcontents))
1440 return Qt;
1441 /* All these slots become local if they are set. */
1442 if (BUFFER_OBJFWDP (valcontents))
1443 return Qt;
1444 if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1445 {
1446 Lisp_Object tail, elt;
1447 for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
1448 {
1449 elt = XCONS (tail)->car;
1450 if (EQ (variable, XCONS (elt)->car))
1451 return Qt;
1452 }
1453 }
1454 return Qnil;
1455 }
1456 \f
1457 /* Find the function at the end of a chain of symbol function indirections. */
1458
1459 /* If OBJECT is a symbol, find the end of its function chain and
1460 return the value found there. If OBJECT is not a symbol, just
1461 return it. If there is a cycle in the function chain, signal a
1462 cyclic-function-indirection error.
1463
1464 This is like Findirect_function, except that it doesn't signal an
1465 error if the chain ends up unbound. */
1466 Lisp_Object
1467 indirect_function (object)
1468 register Lisp_Object object;
1469 {
1470 Lisp_Object tortoise, hare;
1471
1472 hare = tortoise = object;
1473
1474 for (;;)
1475 {
1476 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1477 break;
1478 hare = XSYMBOL (hare)->function;
1479 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1480 break;
1481 hare = XSYMBOL (hare)->function;
1482
1483 tortoise = XSYMBOL (tortoise)->function;
1484
1485 if (EQ (hare, tortoise))
1486 Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
1487 }
1488
1489 return hare;
1490 }
1491
1492 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
1493 "Return the function at the end of OBJECT's function chain.\n\
1494 If OBJECT is a symbol, follow all function indirections and return the final\n\
1495 function binding.\n\
1496 If OBJECT is not a symbol, just return it.\n\
1497 Signal a void-function error if the final symbol is unbound.\n\
1498 Signal a cyclic-function-indirection error if there is a loop in the\n\
1499 function chain of symbols.")
1500 (object)
1501 register Lisp_Object object;
1502 {
1503 Lisp_Object result;
1504
1505 result = indirect_function (object);
1506
1507 if (EQ (result, Qunbound))
1508 return Fsignal (Qvoid_function, Fcons (object, Qnil));
1509 return result;
1510 }
1511 \f
1512 /* Extract and set vector and string elements */
1513
1514 DEFUN ("aref", Faref, Saref, 2, 2, 0,
1515 "Return the element of ARRAY at index IDX.\n\
1516 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1517 or a byte-code object. IDX starts at 0.")
1518 (array, idx)
1519 register Lisp_Object array;
1520 Lisp_Object idx;
1521 {
1522 register int idxval;
1523
1524 CHECK_NUMBER (idx, 1);
1525 idxval = XINT (idx);
1526 if (STRINGP (array))
1527 {
1528 Lisp_Object val;
1529 if (idxval < 0 || idxval >= XSTRING (array)->size)
1530 args_out_of_range (array, idx);
1531 XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
1532 return val;
1533 }
1534 else if (BOOL_VECTOR_P (array))
1535 {
1536 int val;
1537
1538 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1539 args_out_of_range (array, idx);
1540
1541 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1542 return (val & (1 << (idxval % BITS_PER_CHAR)) ? Qt : Qnil);
1543 }
1544 else if (CHAR_TABLE_P (array))
1545 {
1546 Lisp_Object val;
1547
1548 if (idxval < 0)
1549 args_out_of_range (array, idx);
1550 if (idxval < CHAR_TABLE_SINGLE_BYTE_SLOTS)
1551 {
1552 /* For ASCII and 8-bit European characters, the element is
1553 stored in the top table. */
1554 val = XCHAR_TABLE (array)->contents[idxval];
1555 if (NILP (val))
1556 val = XCHAR_TABLE (array)->defalt;
1557 while (NILP (val)) /* Follow parents until we find some value. */
1558 {
1559 array = XCHAR_TABLE (array)->parent;
1560 if (NILP (array))
1561 return Qnil;
1562 val = XCHAR_TABLE (array)->contents[idxval];
1563 if (NILP (val))
1564 val = XCHAR_TABLE (array)->defalt;
1565 }
1566 return val;
1567 }
1568 else
1569 {
1570 int code[4], i;
1571 Lisp_Object sub_table;
1572
1573 SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
1574 if (code[0] != CHARSET_COMPOSITION)
1575 {
1576 if (code[1] < 32) code[1] = -1;
1577 else if (code[2] < 32) code[2] = -1;
1578 }
1579 /* Here, the possible range of CODE[0] (== charset ID) is
1580 128..MAX_CHARSET. Since the top level char table contains
1581 data for multibyte characters after 256th element, we must
1582 increment CODE[0] by 128 to get a correct index. */
1583 code[0] += 128;
1584 code[3] = -1; /* anchor */
1585
1586 try_parent_char_table:
1587 sub_table = array;
1588 for (i = 0; code[i] >= 0; i++)
1589 {
1590 val = XCHAR_TABLE (sub_table)->contents[code[i]];
1591 if (SUB_CHAR_TABLE_P (val))
1592 sub_table = val;
1593 else
1594 {
1595 if (NILP (val))
1596 val = XCHAR_TABLE (sub_table)->defalt;
1597 if (NILP (val))
1598 {
1599 array = XCHAR_TABLE (array)->parent;
1600 if (!NILP (array))
1601 goto try_parent_char_table;
1602 }
1603 return val;
1604 }
1605 }
1606 /* Here, VAL is a sub char table. We try the default value
1607 and parent. */
1608 val = XCHAR_TABLE (val)->defalt;
1609 if (NILP (val))
1610 {
1611 array = XCHAR_TABLE (array)->parent;
1612 if (!NILP (array))
1613 goto try_parent_char_table;
1614 }
1615 return val;
1616 }
1617 }
1618 else
1619 {
1620 int size;
1621 if (VECTORP (array))
1622 size = XVECTOR (array)->size;
1623 else if (COMPILEDP (array))
1624 size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
1625 else
1626 wrong_type_argument (Qarrayp, array);
1627
1628 if (idxval < 0 || idxval >= size)
1629 args_out_of_range (array, idx);
1630 return XVECTOR (array)->contents[idxval];
1631 }
1632 }
1633
1634 DEFUN ("aset", Faset, Saset, 3, 3, 0,
1635 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1636 ARRAY may be a vector or a string. IDX starts at 0.")
1637 (array, idx, newelt)
1638 register Lisp_Object array;
1639 Lisp_Object idx, newelt;
1640 {
1641 register int idxval;
1642
1643 CHECK_NUMBER (idx, 1);
1644 idxval = XINT (idx);
1645 if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
1646 && ! CHAR_TABLE_P (array))
1647 array = wrong_type_argument (Qarrayp, array);
1648 CHECK_IMPURE (array);
1649
1650 if (VECTORP (array))
1651 {
1652 if (idxval < 0 || idxval >= XVECTOR (array)->size)
1653 args_out_of_range (array, idx);
1654 XVECTOR (array)->contents[idxval] = newelt;
1655 }
1656 else if (BOOL_VECTOR_P (array))
1657 {
1658 int val;
1659
1660 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1661 args_out_of_range (array, idx);
1662
1663 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1664
1665 if (! NILP (newelt))
1666 val |= 1 << (idxval % BITS_PER_CHAR);
1667 else
1668 val &= ~(1 << (idxval % BITS_PER_CHAR));
1669 XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR] = val;
1670 }
1671 else if (CHAR_TABLE_P (array))
1672 {
1673 Lisp_Object val;
1674
1675 if (idxval < 0)
1676 args_out_of_range (array, idx);
1677 if (idxval < CHAR_TABLE_SINGLE_BYTE_SLOTS)
1678 XCHAR_TABLE (array)->contents[idxval] = newelt;
1679 else
1680 {
1681 int code[4], i;
1682 Lisp_Object val;
1683
1684 SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
1685 if (code[0] != CHARSET_COMPOSITION)
1686 {
1687 if (code[1] < 32) code[1] = -1;
1688 else if (code[2] < 32) code[2] = -1;
1689 }
1690 /* See the comment of the corresponding part in Faref. */
1691 code[0] += 128;
1692 code[3] = -1; /* anchor */
1693 for (i = 0; code[i + 1] >= 0; i++)
1694 {
1695 val = XCHAR_TABLE (array)->contents[code[i]];
1696 if (SUB_CHAR_TABLE_P (val))
1697 array = val;
1698 else
1699 /* VAL is a leaf. Create a sub char table with the
1700 default value VAL here and look into it. */
1701 array = (XCHAR_TABLE (array)->contents[code[i]]
1702 = make_sub_char_table (val));
1703 }
1704 XCHAR_TABLE (array)->contents[code[i]] = newelt;
1705 }
1706 }
1707 else
1708 {
1709 if (idxval < 0 || idxval >= XSTRING (array)->size)
1710 args_out_of_range (array, idx);
1711 CHECK_NUMBER (newelt, 2);
1712 XSTRING (array)->data[idxval] = XINT (newelt);
1713 }
1714
1715 return newelt;
1716 }
1717 \f
1718 /* Arithmetic functions */
1719
1720 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
1721
1722 Lisp_Object
1723 arithcompare (num1, num2, comparison)
1724 Lisp_Object num1, num2;
1725 enum comparison comparison;
1726 {
1727 double f1, f2;
1728 int floatp = 0;
1729
1730 #ifdef LISP_FLOAT_TYPE
1731 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
1732 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
1733
1734 if (FLOATP (num1) || FLOATP (num2))
1735 {
1736 floatp = 1;
1737 f1 = (FLOATP (num1)) ? XFLOAT (num1)->data : XINT (num1);
1738 f2 = (FLOATP (num2)) ? XFLOAT (num2)->data : XINT (num2);
1739 }
1740 #else
1741 CHECK_NUMBER_COERCE_MARKER (num1, 0);
1742 CHECK_NUMBER_COERCE_MARKER (num2, 0);
1743 #endif /* LISP_FLOAT_TYPE */
1744
1745 switch (comparison)
1746 {
1747 case equal:
1748 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
1749 return Qt;
1750 return Qnil;
1751
1752 case notequal:
1753 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
1754 return Qt;
1755 return Qnil;
1756
1757 case less:
1758 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
1759 return Qt;
1760 return Qnil;
1761
1762 case less_or_equal:
1763 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
1764 return Qt;
1765 return Qnil;
1766
1767 case grtr:
1768 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
1769 return Qt;
1770 return Qnil;
1771
1772 case grtr_or_equal:
1773 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
1774 return Qt;
1775 return Qnil;
1776
1777 default:
1778 abort ();
1779 }
1780 }
1781
1782 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
1783 "T if two args, both numbers or markers, are equal.")
1784 (num1, num2)
1785 register Lisp_Object num1, num2;
1786 {
1787 return arithcompare (num1, num2, equal);
1788 }
1789
1790 DEFUN ("<", Flss, Slss, 2, 2, 0,
1791 "T if first arg is less than second arg. Both must be numbers or markers.")
1792 (num1, num2)
1793 register Lisp_Object num1, num2;
1794 {
1795 return arithcompare (num1, num2, less);
1796 }
1797
1798 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
1799 "T if first arg is greater than second arg. Both must be numbers or markers.")
1800 (num1, num2)
1801 register Lisp_Object num1, num2;
1802 {
1803 return arithcompare (num1, num2, grtr);
1804 }
1805
1806 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
1807 "T if first arg is less than or equal to second arg.\n\
1808 Both must be numbers or markers.")
1809 (num1, num2)
1810 register Lisp_Object num1, num2;
1811 {
1812 return arithcompare (num1, num2, less_or_equal);
1813 }
1814
1815 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
1816 "T if first arg is greater than or equal to second arg.\n\
1817 Both must be numbers or markers.")
1818 (num1, num2)
1819 register Lisp_Object num1, num2;
1820 {
1821 return arithcompare (num1, num2, grtr_or_equal);
1822 }
1823
1824 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
1825 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1826 (num1, num2)
1827 register Lisp_Object num1, num2;
1828 {
1829 return arithcompare (num1, num2, notequal);
1830 }
1831
1832 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
1833 (number)
1834 register Lisp_Object number;
1835 {
1836 #ifdef LISP_FLOAT_TYPE
1837 CHECK_NUMBER_OR_FLOAT (number, 0);
1838
1839 if (FLOATP (number))
1840 {
1841 if (XFLOAT(number)->data == 0.0)
1842 return Qt;
1843 return Qnil;
1844 }
1845 #else
1846 CHECK_NUMBER (number, 0);
1847 #endif /* LISP_FLOAT_TYPE */
1848
1849 if (!XINT (number))
1850 return Qt;
1851 return Qnil;
1852 }
1853 \f
1854 /* Convert between long values and pairs of Lisp integers. */
1855
1856 Lisp_Object
1857 long_to_cons (i)
1858 unsigned long i;
1859 {
1860 unsigned int top = i >> 16;
1861 unsigned int bot = i & 0xFFFF;
1862 if (top == 0)
1863 return make_number (bot);
1864 if (top == (unsigned long)-1 >> 16)
1865 return Fcons (make_number (-1), make_number (bot));
1866 return Fcons (make_number (top), make_number (bot));
1867 }
1868
1869 unsigned long
1870 cons_to_long (c)
1871 Lisp_Object c;
1872 {
1873 Lisp_Object top, bot;
1874 if (INTEGERP (c))
1875 return XINT (c);
1876 top = XCONS (c)->car;
1877 bot = XCONS (c)->cdr;
1878 if (CONSP (bot))
1879 bot = XCONS (bot)->car;
1880 return ((XINT (top) << 16) | XINT (bot));
1881 }
1882 \f
1883 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
1884 "Convert NUMBER to a string by printing it in decimal.\n\
1885 Uses a minus sign if negative.\n\
1886 NUMBER may be an integer or a floating point number.")
1887 (number)
1888 Lisp_Object number;
1889 {
1890 char buffer[VALBITS];
1891
1892 #ifndef LISP_FLOAT_TYPE
1893 CHECK_NUMBER (number, 0);
1894 #else
1895 CHECK_NUMBER_OR_FLOAT (number, 0);
1896
1897 if (FLOATP (number))
1898 {
1899 char pigbuf[350]; /* see comments in float_to_string */
1900
1901 float_to_string (pigbuf, XFLOAT(number)->data);
1902 return build_string (pigbuf);
1903 }
1904 #endif /* LISP_FLOAT_TYPE */
1905
1906 if (sizeof (int) == sizeof (EMACS_INT))
1907 sprintf (buffer, "%d", XINT (number));
1908 else if (sizeof (long) == sizeof (EMACS_INT))
1909 sprintf (buffer, "%ld", XINT (number));
1910 else
1911 abort ();
1912 return build_string (buffer);
1913 }
1914
1915 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
1916 "Convert STRING to a number by parsing it as a decimal number.\n\
1917 This parses both integers and floating point numbers.\n\
1918 It ignores leading spaces and tabs.")
1919 (string)
1920 register Lisp_Object string;
1921 {
1922 Lisp_Object value;
1923 unsigned char *p;
1924
1925 CHECK_STRING (string, 0);
1926
1927 p = XSTRING (string)->data;
1928
1929 /* Skip any whitespace at the front of the number. Some versions of
1930 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1931 while (*p == ' ' || *p == '\t')
1932 p++;
1933
1934 #ifdef LISP_FLOAT_TYPE
1935 if (isfloat_string (p))
1936 return make_float (atof (p));
1937 #endif /* LISP_FLOAT_TYPE */
1938
1939 if (sizeof (int) == sizeof (EMACS_INT))
1940 XSETINT (value, atoi (p));
1941 else if (sizeof (long) == sizeof (EMACS_INT))
1942 XSETINT (value, atol (p));
1943 else
1944 abort ();
1945 return value;
1946 }
1947 \f
1948 enum arithop
1949 { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
1950
1951 extern Lisp_Object float_arith_driver ();
1952 extern Lisp_Object fmod_float ();
1953
1954 Lisp_Object
1955 arith_driver (code, nargs, args)
1956 enum arithop code;
1957 int nargs;
1958 register Lisp_Object *args;
1959 {
1960 register Lisp_Object val;
1961 register int argnum;
1962 register EMACS_INT accum;
1963 register EMACS_INT next;
1964
1965 switch (SWITCH_ENUM_CAST (code))
1966 {
1967 case Alogior:
1968 case Alogxor:
1969 case Aadd:
1970 case Asub:
1971 accum = 0; break;
1972 case Amult:
1973 accum = 1; break;
1974 case Alogand:
1975 accum = -1; break;
1976 }
1977
1978 for (argnum = 0; argnum < nargs; argnum++)
1979 {
1980 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1981 #ifdef LISP_FLOAT_TYPE
1982 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
1983
1984 if (FLOATP (val)) /* time to do serious math */
1985 return (float_arith_driver ((double) accum, argnum, code,
1986 nargs, args));
1987 #else
1988 CHECK_NUMBER_COERCE_MARKER (val, argnum);
1989 #endif /* LISP_FLOAT_TYPE */
1990 args[argnum] = val; /* runs into a compiler bug. */
1991 next = XINT (args[argnum]);
1992 switch (SWITCH_ENUM_CAST (code))
1993 {
1994 case Aadd: accum += next; break;
1995 case Asub:
1996 if (!argnum && nargs != 1)
1997 next = - next;
1998 accum -= next;
1999 break;
2000 case Amult: accum *= next; break;
2001 case Adiv:
2002 if (!argnum) accum = next;
2003 else
2004 {
2005 if (next == 0)
2006 Fsignal (Qarith_error, Qnil);
2007 accum /= next;
2008 }
2009 break;
2010 case Alogand: accum &= next; break;
2011 case Alogior: accum |= next; break;
2012 case Alogxor: accum ^= next; break;
2013 case Amax: if (!argnum || next > accum) accum = next; break;
2014 case Amin: if (!argnum || next < accum) accum = next; break;
2015 }
2016 }
2017
2018 XSETINT (val, accum);
2019 return val;
2020 }
2021
2022 #undef isnan
2023 #define isnan(x) ((x) != (x))
2024
2025 #ifdef LISP_FLOAT_TYPE
2026
2027 Lisp_Object
2028 float_arith_driver (accum, argnum, code, nargs, args)
2029 double accum;
2030 register int argnum;
2031 enum arithop code;
2032 int nargs;
2033 register Lisp_Object *args;
2034 {
2035 register Lisp_Object val;
2036 double next;
2037
2038 for (; argnum < nargs; argnum++)
2039 {
2040 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2041 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
2042
2043 if (FLOATP (val))
2044 {
2045 next = XFLOAT (val)->data;
2046 }
2047 else
2048 {
2049 args[argnum] = val; /* runs into a compiler bug. */
2050 next = XINT (args[argnum]);
2051 }
2052 switch (SWITCH_ENUM_CAST (code))
2053 {
2054 case Aadd:
2055 accum += next;
2056 break;
2057 case Asub:
2058 if (!argnum && nargs != 1)
2059 next = - next;
2060 accum -= next;
2061 break;
2062 case Amult:
2063 accum *= next;
2064 break;
2065 case Adiv:
2066 if (!argnum)
2067 accum = next;
2068 else
2069 {
2070 if (! IEEE_FLOATING_POINT && next == 0)
2071 Fsignal (Qarith_error, Qnil);
2072 accum /= next;
2073 }
2074 break;
2075 case Alogand:
2076 case Alogior:
2077 case Alogxor:
2078 return wrong_type_argument (Qinteger_or_marker_p, val);
2079 case Amax:
2080 if (!argnum || isnan (next) || next > accum)
2081 accum = next;
2082 break;
2083 case Amin:
2084 if (!argnum || isnan (next) || next < accum)
2085 accum = next;
2086 break;
2087 }
2088 }
2089
2090 return make_float (accum);
2091 }
2092 #endif /* LISP_FLOAT_TYPE */
2093
2094 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2095 "Return sum of any number of arguments, which are numbers or markers.")
2096 (nargs, args)
2097 int nargs;
2098 Lisp_Object *args;
2099 {
2100 return arith_driver (Aadd, nargs, args);
2101 }
2102
2103 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2104 "Negate number or subtract numbers or markers.\n\
2105 With one arg, negates it. With more than one arg,\n\
2106 subtracts all but the first from the first.")
2107 (nargs, args)
2108 int nargs;
2109 Lisp_Object *args;
2110 {
2111 return arith_driver (Asub, nargs, args);
2112 }
2113
2114 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2115 "Returns product of any number of arguments, which are numbers or markers.")
2116 (nargs, args)
2117 int nargs;
2118 Lisp_Object *args;
2119 {
2120 return arith_driver (Amult, nargs, args);
2121 }
2122
2123 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
2124 "Returns first argument divided by all the remaining arguments.\n\
2125 The arguments must be numbers or markers.")
2126 (nargs, args)
2127 int nargs;
2128 Lisp_Object *args;
2129 {
2130 return arith_driver (Adiv, nargs, args);
2131 }
2132
2133 DEFUN ("%", Frem, Srem, 2, 2, 0,
2134 "Returns remainder of X divided by Y.\n\
2135 Both must be integers or markers.")
2136 (x, y)
2137 register Lisp_Object x, y;
2138 {
2139 Lisp_Object val;
2140
2141 CHECK_NUMBER_COERCE_MARKER (x, 0);
2142 CHECK_NUMBER_COERCE_MARKER (y, 1);
2143
2144 if (XFASTINT (y) == 0)
2145 Fsignal (Qarith_error, Qnil);
2146
2147 XSETINT (val, XINT (x) % XINT (y));
2148 return val;
2149 }
2150
2151 #ifndef HAVE_FMOD
2152 double
2153 fmod (f1, f2)
2154 double f1, f2;
2155 {
2156 double r = f1;
2157
2158 if (f2 < 0.0)
2159 f2 = -f2;
2160
2161 /* If the magnitude of the result exceeds that of the divisor, or
2162 the sign of the result does not agree with that of the dividend,
2163 iterate with the reduced value. This does not yield a
2164 particularly accurate result, but at least it will be in the
2165 range promised by fmod. */
2166 do
2167 r -= f2 * floor (r / f2);
2168 while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
2169
2170 return r;
2171 }
2172 #endif /* ! HAVE_FMOD */
2173
2174 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2175 "Returns X modulo Y.\n\
2176 The result falls between zero (inclusive) and Y (exclusive).\n\
2177 Both X and Y must be numbers or markers.")
2178 (x, y)
2179 register Lisp_Object x, y;
2180 {
2181 Lisp_Object val;
2182 EMACS_INT i1, i2;
2183
2184 #ifdef LISP_FLOAT_TYPE
2185 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x, 0);
2186 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y, 1);
2187
2188 if (FLOATP (x) || FLOATP (y))
2189 return fmod_float (x, y);
2190
2191 #else /* not LISP_FLOAT_TYPE */
2192 CHECK_NUMBER_COERCE_MARKER (x, 0);
2193 CHECK_NUMBER_COERCE_MARKER (y, 1);
2194 #endif /* not LISP_FLOAT_TYPE */
2195
2196 i1 = XINT (x);
2197 i2 = XINT (y);
2198
2199 if (i2 == 0)
2200 Fsignal (Qarith_error, Qnil);
2201
2202 i1 %= i2;
2203
2204 /* If the "remainder" comes out with the wrong sign, fix it. */
2205 if (i2 < 0 ? i1 > 0 : i1 < 0)
2206 i1 += i2;
2207
2208 XSETINT (val, i1);
2209 return val;
2210 }
2211
2212 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2213 "Return largest of all the arguments (which must be numbers or markers).\n\
2214 The value is always a number; markers are converted to numbers.")
2215 (nargs, args)
2216 int nargs;
2217 Lisp_Object *args;
2218 {
2219 return arith_driver (Amax, nargs, args);
2220 }
2221
2222 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2223 "Return smallest of all the arguments (which must be numbers or markers).\n\
2224 The value is always a number; markers are converted to numbers.")
2225 (nargs, args)
2226 int nargs;
2227 Lisp_Object *args;
2228 {
2229 return arith_driver (Amin, nargs, args);
2230 }
2231
2232 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2233 "Return bitwise-and of all the arguments.\n\
2234 Arguments may be integers, or markers converted to integers.")
2235 (nargs, args)
2236 int nargs;
2237 Lisp_Object *args;
2238 {
2239 return arith_driver (Alogand, nargs, args);
2240 }
2241
2242 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2243 "Return bitwise-or of all the arguments.\n\
2244 Arguments may be integers, or markers converted to integers.")
2245 (nargs, args)
2246 int nargs;
2247 Lisp_Object *args;
2248 {
2249 return arith_driver (Alogior, nargs, args);
2250 }
2251
2252 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2253 "Return bitwise-exclusive-or of all the arguments.\n\
2254 Arguments may be integers, or markers converted to integers.")
2255 (nargs, args)
2256 int nargs;
2257 Lisp_Object *args;
2258 {
2259 return arith_driver (Alogxor, nargs, args);
2260 }
2261
2262 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2263 "Return VALUE with its bits shifted left by COUNT.\n\
2264 If COUNT is negative, shifting is actually to the right.\n\
2265 In this case, the sign bit is duplicated.")
2266 (value, count)
2267 register Lisp_Object value, count;
2268 {
2269 register Lisp_Object val;
2270
2271 CHECK_NUMBER (value, 0);
2272 CHECK_NUMBER (count, 1);
2273
2274 if (XINT (count) > 0)
2275 XSETINT (val, XINT (value) << XFASTINT (count));
2276 else
2277 XSETINT (val, XINT (value) >> -XINT (count));
2278 return val;
2279 }
2280
2281 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2282 "Return VALUE with its bits shifted left by COUNT.\n\
2283 If COUNT is negative, shifting is actually to the right.\n\
2284 In this case, zeros are shifted in on the left.")
2285 (value, count)
2286 register Lisp_Object value, count;
2287 {
2288 register Lisp_Object val;
2289
2290 CHECK_NUMBER (value, 0);
2291 CHECK_NUMBER (count, 1);
2292
2293 if (XINT (count) > 0)
2294 XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
2295 else
2296 XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
2297 return val;
2298 }
2299
2300 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2301 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2302 Markers are converted to integers.")
2303 (number)
2304 register Lisp_Object number;
2305 {
2306 #ifdef LISP_FLOAT_TYPE
2307 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2308
2309 if (FLOATP (number))
2310 return (make_float (1.0 + XFLOAT (number)->data));
2311 #else
2312 CHECK_NUMBER_COERCE_MARKER (number, 0);
2313 #endif /* LISP_FLOAT_TYPE */
2314
2315 XSETINT (number, XINT (number) + 1);
2316 return number;
2317 }
2318
2319 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
2320 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2321 Markers are converted to integers.")
2322 (number)
2323 register Lisp_Object number;
2324 {
2325 #ifdef LISP_FLOAT_TYPE
2326 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2327
2328 if (FLOATP (number))
2329 return (make_float (-1.0 + XFLOAT (number)->data));
2330 #else
2331 CHECK_NUMBER_COERCE_MARKER (number, 0);
2332 #endif /* LISP_FLOAT_TYPE */
2333
2334 XSETINT (number, XINT (number) - 1);
2335 return number;
2336 }
2337
2338 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2339 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2340 (number)
2341 register Lisp_Object number;
2342 {
2343 CHECK_NUMBER (number, 0);
2344 XSETINT (number, ~XINT (number));
2345 return number;
2346 }
2347 \f
2348 void
2349 syms_of_data ()
2350 {
2351 Lisp_Object error_tail, arith_tail;
2352
2353 Qquote = intern ("quote");
2354 Qlambda = intern ("lambda");
2355 Qsubr = intern ("subr");
2356 Qerror_conditions = intern ("error-conditions");
2357 Qerror_message = intern ("error-message");
2358 Qtop_level = intern ("top-level");
2359
2360 Qerror = intern ("error");
2361 Qquit = intern ("quit");
2362 Qwrong_type_argument = intern ("wrong-type-argument");
2363 Qargs_out_of_range = intern ("args-out-of-range");
2364 Qvoid_function = intern ("void-function");
2365 Qcyclic_function_indirection = intern ("cyclic-function-indirection");
2366 Qvoid_variable = intern ("void-variable");
2367 Qsetting_constant = intern ("setting-constant");
2368 Qinvalid_read_syntax = intern ("invalid-read-syntax");
2369
2370 Qinvalid_function = intern ("invalid-function");
2371 Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
2372 Qno_catch = intern ("no-catch");
2373 Qend_of_file = intern ("end-of-file");
2374 Qarith_error = intern ("arith-error");
2375 Qbeginning_of_buffer = intern ("beginning-of-buffer");
2376 Qend_of_buffer = intern ("end-of-buffer");
2377 Qbuffer_read_only = intern ("buffer-read-only");
2378 Qmark_inactive = intern ("mark-inactive");
2379
2380 Qlistp = intern ("listp");
2381 Qconsp = intern ("consp");
2382 Qsymbolp = intern ("symbolp");
2383 Qintegerp = intern ("integerp");
2384 Qnatnump = intern ("natnump");
2385 Qwholenump = intern ("wholenump");
2386 Qstringp = intern ("stringp");
2387 Qarrayp = intern ("arrayp");
2388 Qsequencep = intern ("sequencep");
2389 Qbufferp = intern ("bufferp");
2390 Qvectorp = intern ("vectorp");
2391 Qchar_or_string_p = intern ("char-or-string-p");
2392 Qmarkerp = intern ("markerp");
2393 Qbuffer_or_string_p = intern ("buffer-or-string-p");
2394 Qinteger_or_marker_p = intern ("integer-or-marker-p");
2395 Qboundp = intern ("boundp");
2396 Qfboundp = intern ("fboundp");
2397
2398 #ifdef LISP_FLOAT_TYPE
2399 Qfloatp = intern ("floatp");
2400 Qnumberp = intern ("numberp");
2401 Qnumber_or_marker_p = intern ("number-or-marker-p");
2402 #endif /* LISP_FLOAT_TYPE */
2403
2404 Qchar_table_p = intern ("char-table-p");
2405 Qvector_or_char_table_p = intern ("vector-or-char-table-p");
2406
2407 Qcdr = intern ("cdr");
2408
2409 /* Handle automatic advice activation */
2410 Qad_advice_info = intern ("ad-advice-info");
2411 Qad_activate = intern ("ad-activate");
2412
2413 error_tail = Fcons (Qerror, Qnil);
2414
2415 /* ERROR is used as a signaler for random errors for which nothing else is right */
2416
2417 Fput (Qerror, Qerror_conditions,
2418 error_tail);
2419 Fput (Qerror, Qerror_message,
2420 build_string ("error"));
2421
2422 Fput (Qquit, Qerror_conditions,
2423 Fcons (Qquit, Qnil));
2424 Fput (Qquit, Qerror_message,
2425 build_string ("Quit"));
2426
2427 Fput (Qwrong_type_argument, Qerror_conditions,
2428 Fcons (Qwrong_type_argument, error_tail));
2429 Fput (Qwrong_type_argument, Qerror_message,
2430 build_string ("Wrong type argument"));
2431
2432 Fput (Qargs_out_of_range, Qerror_conditions,
2433 Fcons (Qargs_out_of_range, error_tail));
2434 Fput (Qargs_out_of_range, Qerror_message,
2435 build_string ("Args out of range"));
2436
2437 Fput (Qvoid_function, Qerror_conditions,
2438 Fcons (Qvoid_function, error_tail));
2439 Fput (Qvoid_function, Qerror_message,
2440 build_string ("Symbol's function definition is void"));
2441
2442 Fput (Qcyclic_function_indirection, Qerror_conditions,
2443 Fcons (Qcyclic_function_indirection, error_tail));
2444 Fput (Qcyclic_function_indirection, Qerror_message,
2445 build_string ("Symbol's chain of function indirections contains a loop"));
2446
2447 Fput (Qvoid_variable, Qerror_conditions,
2448 Fcons (Qvoid_variable, error_tail));
2449 Fput (Qvoid_variable, Qerror_message,
2450 build_string ("Symbol's value as variable is void"));
2451
2452 Fput (Qsetting_constant, Qerror_conditions,
2453 Fcons (Qsetting_constant, error_tail));
2454 Fput (Qsetting_constant, Qerror_message,
2455 build_string ("Attempt to set a constant symbol"));
2456
2457 Fput (Qinvalid_read_syntax, Qerror_conditions,
2458 Fcons (Qinvalid_read_syntax, error_tail));
2459 Fput (Qinvalid_read_syntax, Qerror_message,
2460 build_string ("Invalid read syntax"));
2461
2462 Fput (Qinvalid_function, Qerror_conditions,
2463 Fcons (Qinvalid_function, error_tail));
2464 Fput (Qinvalid_function, Qerror_message,
2465 build_string ("Invalid function"));
2466
2467 Fput (Qwrong_number_of_arguments, Qerror_conditions,
2468 Fcons (Qwrong_number_of_arguments, error_tail));
2469 Fput (Qwrong_number_of_arguments, Qerror_message,
2470 build_string ("Wrong number of arguments"));
2471
2472 Fput (Qno_catch, Qerror_conditions,
2473 Fcons (Qno_catch, error_tail));
2474 Fput (Qno_catch, Qerror_message,
2475 build_string ("No catch for tag"));
2476
2477 Fput (Qend_of_file, Qerror_conditions,
2478 Fcons (Qend_of_file, error_tail));
2479 Fput (Qend_of_file, Qerror_message,
2480 build_string ("End of file during parsing"));
2481
2482 arith_tail = Fcons (Qarith_error, error_tail);
2483 Fput (Qarith_error, Qerror_conditions,
2484 arith_tail);
2485 Fput (Qarith_error, Qerror_message,
2486 build_string ("Arithmetic error"));
2487
2488 Fput (Qbeginning_of_buffer, Qerror_conditions,
2489 Fcons (Qbeginning_of_buffer, error_tail));
2490 Fput (Qbeginning_of_buffer, Qerror_message,
2491 build_string ("Beginning of buffer"));
2492
2493 Fput (Qend_of_buffer, Qerror_conditions,
2494 Fcons (Qend_of_buffer, error_tail));
2495 Fput (Qend_of_buffer, Qerror_message,
2496 build_string ("End of buffer"));
2497
2498 Fput (Qbuffer_read_only, Qerror_conditions,
2499 Fcons (Qbuffer_read_only, error_tail));
2500 Fput (Qbuffer_read_only, Qerror_message,
2501 build_string ("Buffer is read-only"));
2502
2503 #ifdef LISP_FLOAT_TYPE
2504 Qrange_error = intern ("range-error");
2505 Qdomain_error = intern ("domain-error");
2506 Qsingularity_error = intern ("singularity-error");
2507 Qoverflow_error = intern ("overflow-error");
2508 Qunderflow_error = intern ("underflow-error");
2509
2510 Fput (Qdomain_error, Qerror_conditions,
2511 Fcons (Qdomain_error, arith_tail));
2512 Fput (Qdomain_error, Qerror_message,
2513 build_string ("Arithmetic domain error"));
2514
2515 Fput (Qrange_error, Qerror_conditions,
2516 Fcons (Qrange_error, arith_tail));
2517 Fput (Qrange_error, Qerror_message,
2518 build_string ("Arithmetic range error"));
2519
2520 Fput (Qsingularity_error, Qerror_conditions,
2521 Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
2522 Fput (Qsingularity_error, Qerror_message,
2523 build_string ("Arithmetic singularity error"));
2524
2525 Fput (Qoverflow_error, Qerror_conditions,
2526 Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
2527 Fput (Qoverflow_error, Qerror_message,
2528 build_string ("Arithmetic overflow error"));
2529
2530 Fput (Qunderflow_error, Qerror_conditions,
2531 Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
2532 Fput (Qunderflow_error, Qerror_message,
2533 build_string ("Arithmetic underflow error"));
2534
2535 staticpro (&Qrange_error);
2536 staticpro (&Qdomain_error);
2537 staticpro (&Qsingularity_error);
2538 staticpro (&Qoverflow_error);
2539 staticpro (&Qunderflow_error);
2540 #endif /* LISP_FLOAT_TYPE */
2541
2542 staticpro (&Qnil);
2543 staticpro (&Qt);
2544 staticpro (&Qquote);
2545 staticpro (&Qlambda);
2546 staticpro (&Qsubr);
2547 staticpro (&Qunbound);
2548 staticpro (&Qerror_conditions);
2549 staticpro (&Qerror_message);
2550 staticpro (&Qtop_level);
2551
2552 staticpro (&Qerror);
2553 staticpro (&Qquit);
2554 staticpro (&Qwrong_type_argument);
2555 staticpro (&Qargs_out_of_range);
2556 staticpro (&Qvoid_function);
2557 staticpro (&Qcyclic_function_indirection);
2558 staticpro (&Qvoid_variable);
2559 staticpro (&Qsetting_constant);
2560 staticpro (&Qinvalid_read_syntax);
2561 staticpro (&Qwrong_number_of_arguments);
2562 staticpro (&Qinvalid_function);
2563 staticpro (&Qno_catch);
2564 staticpro (&Qend_of_file);
2565 staticpro (&Qarith_error);
2566 staticpro (&Qbeginning_of_buffer);
2567 staticpro (&Qend_of_buffer);
2568 staticpro (&Qbuffer_read_only);
2569 staticpro (&Qmark_inactive);
2570
2571 staticpro (&Qlistp);
2572 staticpro (&Qconsp);
2573 staticpro (&Qsymbolp);
2574 staticpro (&Qintegerp);
2575 staticpro (&Qnatnump);
2576 staticpro (&Qwholenump);
2577 staticpro (&Qstringp);
2578 staticpro (&Qarrayp);
2579 staticpro (&Qsequencep);
2580 staticpro (&Qbufferp);
2581 staticpro (&Qvectorp);
2582 staticpro (&Qchar_or_string_p);
2583 staticpro (&Qmarkerp);
2584 staticpro (&Qbuffer_or_string_p);
2585 staticpro (&Qinteger_or_marker_p);
2586 #ifdef LISP_FLOAT_TYPE
2587 staticpro (&Qfloatp);
2588 staticpro (&Qnumberp);
2589 staticpro (&Qnumber_or_marker_p);
2590 #endif /* LISP_FLOAT_TYPE */
2591 staticpro (&Qchar_table_p);
2592 staticpro (&Qvector_or_char_table_p);
2593
2594 staticpro (&Qboundp);
2595 staticpro (&Qfboundp);
2596 staticpro (&Qcdr);
2597 staticpro (&Qad_advice_info);
2598 staticpro (&Qad_activate);
2599
2600 /* Types that type-of returns. */
2601 Qinteger = intern ("integer");
2602 Qsymbol = intern ("symbol");
2603 Qstring = intern ("string");
2604 Qcons = intern ("cons");
2605 Qmarker = intern ("marker");
2606 Qoverlay = intern ("overlay");
2607 Qfloat = intern ("float");
2608 Qwindow_configuration = intern ("window-configuration");
2609 Qprocess = intern ("process");
2610 Qwindow = intern ("window");
2611 /* Qsubr = intern ("subr"); */
2612 Qcompiled_function = intern ("compiled-function");
2613 Qbuffer = intern ("buffer");
2614 Qframe = intern ("frame");
2615 Qvector = intern ("vector");
2616 Qchar_table = intern ("char-table");
2617 Qbool_vector = intern ("bool-vector");
2618
2619 staticpro (&Qinteger);
2620 staticpro (&Qsymbol);
2621 staticpro (&Qstring);
2622 staticpro (&Qcons);
2623 staticpro (&Qmarker);
2624 staticpro (&Qoverlay);
2625 staticpro (&Qfloat);
2626 staticpro (&Qwindow_configuration);
2627 staticpro (&Qprocess);
2628 staticpro (&Qwindow);
2629 /* staticpro (&Qsubr); */
2630 staticpro (&Qcompiled_function);
2631 staticpro (&Qbuffer);
2632 staticpro (&Qframe);
2633 staticpro (&Qvector);
2634 staticpro (&Qchar_table);
2635 staticpro (&Qbool_vector);
2636
2637 defsubr (&Seq);
2638 defsubr (&Snull);
2639 defsubr (&Stype_of);
2640 defsubr (&Slistp);
2641 defsubr (&Snlistp);
2642 defsubr (&Sconsp);
2643 defsubr (&Satom);
2644 defsubr (&Sintegerp);
2645 defsubr (&Sinteger_or_marker_p);
2646 defsubr (&Snumberp);
2647 defsubr (&Snumber_or_marker_p);
2648 #ifdef LISP_FLOAT_TYPE
2649 defsubr (&Sfloatp);
2650 #endif /* LISP_FLOAT_TYPE */
2651 defsubr (&Snatnump);
2652 defsubr (&Ssymbolp);
2653 defsubr (&Sstringp);
2654 defsubr (&Svectorp);
2655 defsubr (&Schar_table_p);
2656 defsubr (&Svector_or_char_table_p);
2657 defsubr (&Sbool_vector_p);
2658 defsubr (&Sarrayp);
2659 defsubr (&Ssequencep);
2660 defsubr (&Sbufferp);
2661 defsubr (&Smarkerp);
2662 defsubr (&Ssubrp);
2663 defsubr (&Sbyte_code_function_p);
2664 defsubr (&Schar_or_string_p);
2665 defsubr (&Scar);
2666 defsubr (&Scdr);
2667 defsubr (&Scar_safe);
2668 defsubr (&Scdr_safe);
2669 defsubr (&Ssetcar);
2670 defsubr (&Ssetcdr);
2671 defsubr (&Ssymbol_function);
2672 defsubr (&Sindirect_function);
2673 defsubr (&Ssymbol_plist);
2674 defsubr (&Ssymbol_name);
2675 defsubr (&Smakunbound);
2676 defsubr (&Sfmakunbound);
2677 defsubr (&Sboundp);
2678 defsubr (&Sfboundp);
2679 defsubr (&Sfset);
2680 defsubr (&Sdefalias);
2681 defsubr (&Ssetplist);
2682 defsubr (&Ssymbol_value);
2683 defsubr (&Sset);
2684 defsubr (&Sdefault_boundp);
2685 defsubr (&Sdefault_value);
2686 defsubr (&Sset_default);
2687 defsubr (&Ssetq_default);
2688 defsubr (&Smake_variable_buffer_local);
2689 defsubr (&Smake_local_variable);
2690 defsubr (&Skill_local_variable);
2691 defsubr (&Slocal_variable_p);
2692 defsubr (&Slocal_variable_if_set_p);
2693 defsubr (&Saref);
2694 defsubr (&Saset);
2695 defsubr (&Snumber_to_string);
2696 defsubr (&Sstring_to_number);
2697 defsubr (&Seqlsign);
2698 defsubr (&Slss);
2699 defsubr (&Sgtr);
2700 defsubr (&Sleq);
2701 defsubr (&Sgeq);
2702 defsubr (&Sneq);
2703 defsubr (&Szerop);
2704 defsubr (&Splus);
2705 defsubr (&Sminus);
2706 defsubr (&Stimes);
2707 defsubr (&Squo);
2708 defsubr (&Srem);
2709 defsubr (&Smod);
2710 defsubr (&Smax);
2711 defsubr (&Smin);
2712 defsubr (&Slogand);
2713 defsubr (&Slogior);
2714 defsubr (&Slogxor);
2715 defsubr (&Slsh);
2716 defsubr (&Sash);
2717 defsubr (&Sadd1);
2718 defsubr (&Ssub1);
2719 defsubr (&Slognot);
2720
2721 XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
2722 }
2723
2724 SIGTYPE
2725 arith_error (signo)
2726 int signo;
2727 {
2728 #if defined(USG) && !defined(POSIX_SIGNALS)
2729 /* USG systems forget handlers when they are used;
2730 must reestablish each time */
2731 signal (signo, arith_error);
2732 #endif /* USG */
2733 #ifdef VMS
2734 /* VMS systems are like USG. */
2735 signal (signo, arith_error);
2736 #endif /* VMS */
2737 #ifdef BSD4_1
2738 sigrelse (SIGFPE);
2739 #else /* not BSD4_1 */
2740 sigsetmask (SIGEMPTYMASK);
2741 #endif /* not BSD4_1 */
2742
2743 Fsignal (Qarith_error, Qnil);
2744 }
2745
2746 init_data ()
2747 {
2748 /* Don't do this if just dumping out.
2749 We don't want to call `signal' in this case
2750 so that we don't have trouble with dumping
2751 signal-delivering routines in an inconsistent state. */
2752 #ifndef CANNOT_DUMP
2753 if (!initialized)
2754 return;
2755 #endif /* CANNOT_DUMP */
2756 signal (SIGFPE, arith_error);
2757
2758 #ifdef uts
2759 signal (SIGEMT, arith_error);
2760 #endif /* uts */
2761 }
Emacs repository mirror