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