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