![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to data.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / src|
Return to data.c CVS log | Up to [Apple XNU] / GNUtools / emacs / src |
1.1 root 1: /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2: Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA. */
19:
20:
21: /* This must precede sys/signal.h on certain machines. */
22: #include <sys/types.h>
23: #include <signal.h>
24:
25: #include "config.h"
26: #include "lisp.h"
27:
28: #ifndef standalone
29: #include "buffer.h"
30: #endif
31:
32: #include "emacssignal.h"
33:
34: Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
35: Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
36: Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
37: Lisp_Object Qvoid_variable, Qvoid_function;
38: Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
39: Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
40: Lisp_Object Qend_of_file, Qarith_error;
41: Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
42: Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qlistp, Qconsp;
43: Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
44: Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
45: Lisp_Object Qboundp, Qfboundp;
46: Lisp_Object Qcdr;
47:
48: Lisp_Object
49: wrong_type_argument (predicate, value)
50: register Lisp_Object predicate, value;
51: {
52: register Lisp_Object tem;
53: do
54: {
55: if (!EQ (Vmocklisp_arguments, Qt))
56: {
57: if (XTYPE (value) == Lisp_String &&
58: (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
59: return Fstring_to_int (value, Qt);
60: if (XTYPE (value) == Lisp_Int && EQ (predicate, Qstringp))
61: return Fint_to_string (value);
62: }
63: value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
64: tem = call1 (predicate, value);
65: }
66: while (NULL (tem));
67: return value;
68: }
69:
70: pure_write_error ()
71: {
72: error ("Attempt to modify read-only object");
73: }
74:
75: void
76: args_out_of_range (a1, a2)
77: Lisp_Object a1, a2;
78: {
79: while (1)
80: Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
81: }
82:
83: void
84: args_out_of_range_3 (a1, a2, a3)
85: Lisp_Object a1, a2, a3;
86: {
87: while (1)
88: Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
89: }
90:
91: Lisp_Object
92: make_number (num)
93: int num;
94: {
95: register Lisp_Object val;
96: XSET (val, Lisp_Int, num);
97: return val;
98: }
99:
100: /* On some machines, XINT needs a temporary location.
101: Here it is, in case it is needed. */
102:
103: int sign_extend_temp;
104:
105: /* On a few machines, XINT can only be done by calling this. */
106:
107: int
108: sign_extend_lisp_int (num)
109: int num;
110: {
111: if (num & (1 << (VALBITS - 1)))
112: return num | ((-1) << VALBITS);
113: else
114: return num & ((1 << VALBITS) - 1);
115: }
116:
117: /* Data type predicates */
118:
119: DEFUN ("eq", Feq, Seq, 2, 2, 0,
120: "T if the two args are the same Lisp object.")
121: (obj1, obj2)
122: Lisp_Object obj1, obj2;
123: {
124: if (EQ (obj1, obj2))
125: return Qt;
126: return Qnil;
127: }
128:
129: DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
130: (obj)
131: Lisp_Object obj;
132: {
133: if (NULL (obj))
134: return Qt;
135: return Qnil;
136: }
137:
138: DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
139: (obj)
140: Lisp_Object obj;
141: {
142: if (XTYPE (obj) == Lisp_Cons)
143: return Qt;
144: return Qnil;
145: }
146:
147: DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
148: (obj)
149: Lisp_Object obj;
150: {
151: if (XTYPE (obj) == Lisp_Cons)
152: return Qnil;
153: return Qt;
154: }
155:
156: DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
157: (obj)
158: Lisp_Object obj;
159: {
160: if (XTYPE (obj) == Lisp_Cons || NULL (obj))
161: return Qt;
162: return Qnil;
163: }
164:
165: DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
166: (obj)
167: Lisp_Object obj;
168: {
169: if (XTYPE (obj) == Lisp_Cons || NULL (obj))
170: return Qnil;
171: return Qt;
172: }
173:
174: DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is a number.")
175: (obj)
176: Lisp_Object obj;
177: {
178: if (XTYPE (obj) == Lisp_Int)
179: return Qt;
180: return Qnil;
181: }
182:
183: DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.")
184: (obj)
185: Lisp_Object obj;
186: {
187: if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0)
188: return Qt;
189: return Qnil;
190: }
191:
192: DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
193: (obj)
194: Lisp_Object obj;
195: {
196: if (XTYPE (obj) == Lisp_Symbol)
197: return Qt;
198: return Qnil;
199: }
200:
201: DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
202: (obj)
203: Lisp_Object obj;
204: {
205: if (XTYPE (obj) == Lisp_Vector)
206: return Qt;
207: return Qnil;
208: }
209:
210: DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
211: (obj)
212: Lisp_Object obj;
213: {
214: if (XTYPE (obj) == Lisp_String)
215: return Qt;
216: return Qnil;
217: }
218:
219: DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
220: (obj)
221: Lisp_Object obj;
222: {
223: if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
224: return Qt;
225: return Qnil;
226: }
227:
228: DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
229: "T if OBJECT is a sequence (list or array).")
230: (obj)
231: register Lisp_Object obj;
232: {
233: if (CONSP (obj) || NULL (obj) ||
234: XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
235: return Qt;
236: return Qnil;
237: }
238:
239: DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
240: (obj)
241: Lisp_Object obj;
242: {
243: if (XTYPE (obj) == Lisp_Buffer)
244: return Qt;
245: return Qnil;
246: }
247:
248: DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
249: (obj)
250: Lisp_Object obj;
251: {
252: if (XTYPE (obj) == Lisp_Marker)
253: return Qt;
254: return Qnil;
255: }
256:
257: DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
258: "T if OBJECT is an integer or a marker (editor pointer).")
259: (obj)
260: register Lisp_Object obj;
261: {
262: if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int)
263: return Qt;
264: return Qnil;
265: }
266:
267: DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
268: (obj)
269: Lisp_Object obj;
270: {
271: if (XTYPE (obj) == Lisp_Subr)
272: return Qt;
273: return Qnil;
274: }
275:
276: DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, "T if OBJECT is a character (a number) or a string.")
277: (obj)
278: register Lisp_Object obj;
279: {
280: if (XTYPE (obj) == Lisp_Int || XTYPE (obj) == Lisp_String)
281: return Qt;
282: return Qnil;
283: }
284:
285: /* Extract and set components of lists */
286:
287: DEFUN ("car", Fcar, Scar, 1, 1, 0,
288: "Return the car of CONSCELL. If arg is nil, return nil.")
289: (list)
290: register Lisp_Object list;
291: {
292: while (1)
293: {
294: if (XTYPE (list) == Lisp_Cons)
295: return XCONS (list)->car;
296: else if (EQ (list, Qnil))
297: return Qnil;
298: else
299: list = wrong_type_argument (Qlistp, list);
300: }
301: }
302:
303: DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
304: "Return the car of OBJECT if it is a cons cell, or else nil.")
305: (object)
306: Lisp_Object object;
307: {
308: if (XTYPE (object) == Lisp_Cons)
309: return XCONS (object)->car;
310: else
311: return Qnil;
312: }
313:
314: DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
315: "Return the cdr of CONSCELL. If arg is nil, return nil.")
316: (list)
317: register Lisp_Object list;
318: {
319: while (1)
320: {
321: if (XTYPE (list) == Lisp_Cons)
322: return XCONS (list)->cdr;
323: else if (EQ (list, Qnil))
324: return Qnil;
325: else
326: list = wrong_type_argument (Qlistp, list);
327: }
328: }
329:
330: DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
331: "Return the cdr of OBJECT if it is a cons cell, or else nil.")
332: (object)
333: Lisp_Object object;
334: {
335: if (XTYPE (object) == Lisp_Cons)
336: return XCONS (object)->cdr;
337: else
338: return Qnil;
339: }
340:
341: DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
342: "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.")
343: (cell, newcar)
344: register Lisp_Object cell, newcar;
345: {
346: if (XTYPE (cell) != Lisp_Cons)
347: cell = wrong_type_argument (Qconsp, cell);
348:
349: CHECK_IMPURE (cell);
350: XCONS (cell)->car = newcar;
351: return newcar;
352: }
353:
354: DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
355: "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.")
356: (cell, newcdr)
357: register Lisp_Object cell, newcdr;
358: {
359: if (XTYPE (cell) != Lisp_Cons)
360: cell = wrong_type_argument (Qconsp, cell);
361:
362: CHECK_IMPURE (cell);
363: XCONS (cell)->cdr = newcdr;
364: return newcdr;
365: }
366:
367: /* Extract and set components of symbols */
368:
369: DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
370: (sym)
371: register Lisp_Object sym;
372: {
373: CHECK_SYMBOL (sym, 0);
374: return (XTYPE (XSYMBOL (sym)->value) == Lisp_Void
375: || EQ (XSYMBOL (sym)->value, Qunbound))
376: ? Qnil : Qt;
377: }
378:
379: DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
380: (sym)
381: register Lisp_Object sym;
382: {
383: CHECK_SYMBOL (sym, 0);
384: return (XTYPE (XSYMBOL (sym)->function) == Lisp_Void
385: || EQ (XSYMBOL (sym)->function, Qunbound))
386: ? Qnil : Qt;
387: }
388:
389: DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
390: (sym)
391: register Lisp_Object sym;
392: {
393: CHECK_SYMBOL (sym, 0);
394: XSYMBOL (sym)->value = Qunbound;
395: return sym;
396: }
397:
398: DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
399: (sym)
400: register Lisp_Object sym;
401: {
402: CHECK_SYMBOL (sym, 0);
403: XSYMBOL (sym)->function = Qunbound;
404: return sym;
405: }
406:
407: DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
408: "Return SYMBOL's function definition.")
409: (sym)
410: register Lisp_Object sym;
411: {
412: CHECK_SYMBOL (sym, 0);
413: if (EQ (XSYMBOL (sym)->function, Qunbound))
414: return Fsignal (Qvoid_function, Fcons (sym, Qnil));
415: return XSYMBOL (sym)->function;
416: }
417:
418: DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
419: (sym)
420: register Lisp_Object sym;
421: {
422: CHECK_SYMBOL (sym, 0);
423: return XSYMBOL (sym)->plist;
424: }
425:
426: DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
427: (sym)
428: register Lisp_Object sym;
429: {
430: register Lisp_Object name;
431:
432: CHECK_SYMBOL (sym, 0);
433: XSET (name, Lisp_String, XSYMBOL (sym)->name);
434: return name;
435: }
436:
437: DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
438: "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
439: (sym, newdef)
440: register Lisp_Object sym, newdef;
441: {
442: CHECK_SYMBOL (sym, 0);
443: if (!NULL (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
444: Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
445: Vautoload_queue);
446: XSYMBOL (sym)->function = newdef;
447: return newdef;
448: }
449:
450: DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
451: "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
452: (sym, newplist)
453: register Lisp_Object sym, newplist;
454: {
455: CHECK_SYMBOL (sym, 0);
456: XSYMBOL (sym)->plist = newplist;
457: return newplist;
458: }
459:
460: /* Getting and setting values of symbols */
461:
462: /* Given the raw contents of a symbol value cell,
463: return the Lisp value of the symbol. */
464:
465: Lisp_Object
466: do_symval_forwarding (valcontents)
467: register Lisp_Object valcontents;
468: {
469: register Lisp_Object val;
470: #ifdef SWITCH_ENUM_BUG
471: switch ((int) XTYPE (valcontents))
472: #else
473: switch (XTYPE (valcontents))
474: #endif
475: {
476: case Lisp_Intfwd:
477: XSET (val, Lisp_Int, *XINTPTR (valcontents));
478: return val;
479:
480: case Lisp_Boolfwd:
481: if (*XINTPTR (valcontents))
482: return Qt;
483: return Qnil;
484:
485: case Lisp_Objfwd:
486: return *XOBJFWD (valcontents);
487:
488: case Lisp_Buffer_Objfwd:
489: return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
490: }
491: return valcontents;
492: }
493:
494: void
495: store_symval_forwarding (sym, valcontents, newval)
496: Lisp_Object sym;
497: register Lisp_Object valcontents, newval;
498: {
499: #ifdef SWITCH_ENUM_BUG
500: switch ((int) XTYPE (valcontents))
501: #else
502: switch (XTYPE (valcontents))
503: #endif
504: {
505: case Lisp_Intfwd:
506: CHECK_NUMBER (newval, 1);
507: *XINTPTR (valcontents) = XINT (newval);
508: break;
509:
510: case Lisp_Boolfwd:
511: *XINTPTR (valcontents) = NULL(newval) ? 0 : 1;
512: break;
513:
514: case Lisp_Objfwd:
515: *XOBJFWD (valcontents) = newval;
516: break;
517:
518: case Lisp_Buffer_Objfwd:
519: *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer) = newval;
520: break;
521:
522: default:
523: valcontents = XSYMBOL (sym)->value;
524: if (XTYPE (valcontents) == Lisp_Buffer_Local_Value ||
525: XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
526: XCONS (XSYMBOL (sym)->value)->car = newval;
527: else
528: XSYMBOL (sym)->value = newval;
529: }
530: }
531:
532: /* Note that it must not be possible to quit within this function.
533: Great care is required for this. */
534:
535: DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0, "Return SYMBOL's value.")
536: (sym)
537: Lisp_Object sym;
538: {
539: register Lisp_Object valcontents, tem1;
540: register Lisp_Object val;
541: CHECK_SYMBOL (sym, 0);
542: valcontents = XSYMBOL (sym)->value;
543:
544: retry:
545: #ifdef SWITCH_ENUM_BUG
546: switch ((int) XTYPE (valcontents))
547: #else
548: switch (XTYPE (valcontents))
549: #endif
550: {
551: case Lisp_Buffer_Local_Value:
552: case Lisp_Some_Buffer_Local_Value:
553: /* valcontents is a list
554: (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
555:
556: CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
557: local_var_alist, that being the element whose car is this variable.
558: Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
559: does not have an element in its alist for this variable.
560:
561: If the current buffer is not BUFFER, we store the current REALVALUE value into
562: CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
563: the buffer now current and set up CURRENT-ALIST-ELEMENT.
564: Then we set REALVALUE out of that element, and store into BUFFER.
565: Note that REALVALUE can be a forwarding pointer. */
566:
567: tem1 = XCONS (XCONS (valcontents)->cdr)->car;
568: if (NULL (tem1) || current_buffer != XBUFFER (tem1))
569: {
570: tem1 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
571: Fsetcdr (tem1, do_symval_forwarding (XCONS (valcontents)->car));
572: tem1 = assq_no_quit (sym, current_buffer->local_var_alist);
573: if (NULL (tem1))
574: tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
575: XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
576: XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer);
577: store_symval_forwarding (sym, XCONS (valcontents)->car, Fcdr (tem1));
578: }
579: valcontents = XCONS (valcontents)->car;
580: goto retry;
581:
582: case Lisp_Intfwd:
583: XSET (val, Lisp_Int, *XINTPTR (valcontents));
584: return val;
585:
586: case Lisp_Boolfwd:
587: if (*XINTPTR (valcontents))
588: return Qt;
589: return Qnil;
590:
591: case Lisp_Objfwd:
592: return *XOBJFWD (valcontents);
593:
594: case Lisp_Buffer_Objfwd:
595: return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
596:
597: case Lisp_Symbol:
598: /* For a symbol, check whether it is 'unbound. */
599: if (!EQ (valcontents, Qunbound))
600: break;
601: /* drops through! */
602: case Lisp_Void:
603: return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
604: }
605: return valcontents;
606: }
607:
608: DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
609: "Return SYMBOL's default value.\n\
610: This is the value that is seen in buffers that do not have their own values\n\
611: for this variable.")
612: (sym)
613: Lisp_Object sym;
614: {
615: register Lisp_Object valcontents;
616:
617: CHECK_SYMBOL (sym, 0);
618: valcontents = XSYMBOL (sym)->value;
619: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
620: {
621: register int idx = XUINT (valcontents);
622:
623: if (*(int *) (idx + (char *) &buffer_local_flags) != 0)
624: return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
625: }
626:
627: if (XTYPE (valcontents) == Lisp_Buffer_Local_Value ||
628: XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
629: return XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr;
630: return Fsymbol_value (sym);
631: }
632:
633: DEFUN ("set", Fset, Sset, 2, 2, 0,
634: "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
635: (sym, newval)
636: register Lisp_Object sym, newval;
637: {
638: #ifndef RTPC_REGISTER_BUG
639: register Lisp_Object valcontents, tem1, current_alist_element;
640: #else /* RTPC_REGISTER_BUG */
641: register Lisp_Object tem1;
642: Lisp_Object valcontents, current_alist_element;
643: #endif /* RTPC_REGISTER_BUG */
644:
645: CHECK_SYMBOL (sym, 0);
646: if (NULL (sym) || EQ (sym, Qt))
647: return Fsignal (Qsetting_constant, Fcons (sym, Qnil));
648: valcontents = XSYMBOL (sym)->value;
649:
650: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
651: {
652: register int idx = XUINT (valcontents);
653: register int mask = *(int *)(idx + (char *) &buffer_local_flags);
654: if (mask > 0)
655: current_buffer->local_var_flags |= mask;
656: }
657:
658: if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
659: || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
660: {
661: /* valcontents is a list
662: (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
663:
664: CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
665: local_var_alist, that being the element whose car is this variable.
666: Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE),
667: if BUFFER does not have an element in its alist for this variable.
668:
669: If the current buffer is not BUFFER, we store the current REALVALUE value into
670: CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
671: the buffer now current and set up CURRENT-ALIST-ELEMENT.
672: Then we set REALVALUE out of that element, and store into BUFFER.
673: Note that REALVALUE can be a forwarding pointer. */
674:
675: current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
676: if (current_buffer
677: != ((XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
678: /* If the current buffer is already cached,
679: we don't need to change that fact. */
680: ? XBUFFER (XCONS (XCONS (valcontents)->cdr)->car)
681: /* If setting the variable should make it local,
682: it's not enough if the current buffer is already cached.
683: We need to make sure it has a local value for the var. */
684: : XBUFFER (XCONS (current_alist_element)->car)))
685: {
686: /* "Swap out" the buffer that was previously cached. */
687: Fsetcdr (current_alist_element,
688: do_symval_forwarding (XCONS (valcontents)->car));
689:
690: /* Encache the current buffer. */
691: tem1 = Fassq (sym, current_buffer->local_var_alist);
692: if (NULL (tem1))
693: {
694: /* This buffer sees the default value still.
695: If type is Lisp_Some_Buffer_Local_Value, set the default value.
696: If type is Lisp_Buffer_Local_Value, give this buffer a local value
697: and set that. */
698: if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
699: tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
700: else
701: {
702: tem1 = Fcons (sym, Fcdr (current_alist_element));
703: current_buffer->local_var_alist = Fcons (tem1, current_buffer->local_var_alist);
704: }
705: }
706: /* Set the CURRENT-ALIST-ELEMENT slot to fit this buffer. */
707: current_alist_element = tem1;
708: XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
709: /* Record this buffer in the BUFFER slot. */
710: XSET (XCONS (XCONS (valcontents)->cdr)->car,
711: Lisp_Buffer, current_buffer);
712: /* Now the CURRENT-ALIST-ELEMENT slot in VALCONTENTS
713: is correct for the current buffer. */
714: }
715: /* If the current buffer sees the default value,
716: set the default value in the CURRENT-ALIST-ELEMENT right now.
717: Don't wait till some other buffer gets cached. */
718: if (XCONS (XCONS (valcontents)->cdr)->cdr == current_alist_element)
719: XCONS (current_alist_element)->cdr = newval;
720: valcontents = XCONS (valcontents)->car;
721: }
722: store_symval_forwarding (sym, valcontents, newval);
723: return newval;
724: }
725:
726: DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
727: "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
728: The default value is seen in buffers that do not have their own values\n\
729: for this variable.")
730: (sym, value)
731: Lisp_Object sym, value;
732: {
733: register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
734:
735: CHECK_SYMBOL (sym, 0);
736: valcontents = XSYMBOL (sym)->value;
737:
738: /* Handle variables like case-fold-search that have special slots
739: in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
740: variables. */
741: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
742: {
743: register int idx = XUINT (valcontents);
744: #ifndef RTPC_REGISTER_BUG
745: register struct buffer *b;
746: #else
747: struct buffer *b;
748: #endif
749: register int mask = *(int *) (idx + (char *) &buffer_local_flags);
750:
751: if (mask < 0)
752: /* -1 means the variable is always local in every buffer.
753: Set the default value, but not any of the local values. */
754: *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
755:
756: if (mask > 0)
757: {
758: /* Positive means a value that is local in some buffers.
759: Set the default value, and also the corresponding slot
760: in buffers where the variable is not local. */
761: *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
762: for (b = all_buffers; b; b = b->next)
763: if (!(b->local_var_flags & mask))
764: *(Lisp_Object *)(idx + (char *) b) = value;
765: }
766: return value;
767: }
768:
769: if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
770: XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
771: return Fset (sym, value);
772:
773: /* Store new value into the DEFAULT-VALUE slot */
774: XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr = value;
775:
776: /* If that slot is current, we must set the REALVALUE slot too */
777: current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
778: alist_element_buffer = Fcar (current_alist_element);
779: if (EQ (alist_element_buffer, current_alist_element))
780: store_symval_forwarding (sym, XCONS (valcontents)->car, value);
781:
782: return value;
783: }
784:
785: DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
786: "Set SYMBOL's default value to VAL. VAL is evaluated; SYMBOL is not.\n\
787: The default value is seen in buffers that do not have their own values\n\
788: for this variable.")
789: (args)
790: Lisp_Object args;
791: {
792: register Lisp_Object val;
793: struct gcpro gcpro1;
794:
795: GCPRO1 (args);
796: val = Feval (Fcar (Fcdr (args)));
797: UNGCPRO;
798: return Fset_default (Fcar (args), val);
799: }
800:
801: DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
802: 1, 1, "vMake Variable Buffer Local: ",
803: "Make VARIABLE have a separate value for each buffer.\n\
804: At any time, the value for the current buffer is in effect.\n\
805: There is also a default value which is seen in any buffer which has not yet\n\
806: set its own value.\n\
807: The function `default-value' gets the default value and `set-default' sets it.\n\
808: Using `set' or `setq' to set the variable causes it to have a separate value\n\
809: for the current buffer if it was previously using the default value.")
810: (sym)
811: register Lisp_Object sym;
812: {
813: register Lisp_Object tem, valcontents;
814:
815: CHECK_SYMBOL (sym, 0);
816:
817: if (EQ (sym, Qnil) || EQ (sym, Qt))
818: error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
819:
820: valcontents = XSYMBOL (sym)->value;
821: if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) ||
822: (XTYPE (valcontents) == Lisp_Buffer_Objfwd))
823: return sym;
824: if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
825: {
826: XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
827: return sym;
828: }
829: if (EQ (valcontents, Qunbound))
830: XSYMBOL (sym)->value = Qnil;
831: tem = Fcons (Qnil, Fsymbol_value (sym));
832: XCONS (tem)->car = tem;
833: XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Fcurrent_buffer (), tem));
834: XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
835: return sym;
836: }
837:
838: DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
839: 1, 1, "vMake Local Variable: ",
840: "Make VARIABLE have a separate value in the current buffer.\n\
841: Other buffers will continue to share a common default value.\n\
842: See also `make-variable-buffer-local'.")
843: (sym)
844: register Lisp_Object sym;
845: {
846: register Lisp_Object tem, valcontents;
847:
848: CHECK_SYMBOL (sym, 0);
849:
850: if (EQ (sym, Qnil) || EQ (sym, Qt))
851: error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
852:
853: valcontents = XSYMBOL (sym)->value;
854: if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) ||
855: (XTYPE (valcontents) == Lisp_Buffer_Objfwd))
856: return sym;
857: /* Make sure sym is set up to hold per-buffer values */
858: if (XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
859: {
860: if (EQ (valcontents, Qunbound))
861: XSYMBOL (sym)->value = Qnil;
862: tem = Fcons (Qnil, Fsymbol_value (sym));
863: XCONS (tem)->car = tem;
864: XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Qnil, tem));
865: XSETTYPE (XSYMBOL (sym)->value, Lisp_Some_Buffer_Local_Value);
866: }
867: /* Make sure this buffer has its own value of sym */
868: tem = Fassq (sym, current_buffer->local_var_alist);
869: if (NULL (tem))
870: {
871: current_buffer->local_var_alist
872: = Fcons (Fcons (sym, XCONS (XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->cdr)->cdr),
873: current_buffer->local_var_alist);
874:
875: /* Make sure symbol does not think it is set up for this buffer;
876: force it to look once again for this buffer's value */
877: {
878: /* This local variable avoids "expression to complex" on IBM RT. */
879: Lisp_Object xs;
880:
881: xs = XSYMBOL (sym)->value;
882: if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car))
883: XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil;
884: }
885: }
886: return sym;
887: }
888:
889: DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
890: 1, 1, "vKill Local Variable: ",
891: "Make VARIABLE no longer have a separate value in the current buffer.\n\
892: From now on the default value will apply in this buffer.")
893: (sym)
894: register Lisp_Object sym;
895: {
896: register Lisp_Object tem, valcontents;
897:
898: CHECK_SYMBOL (sym, 0);
899:
900: valcontents = XSYMBOL (sym)->value;
901:
902: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
903: {
904: register int idx = XUINT (valcontents);
905: register int mask = *(int *) (idx + (char *) &buffer_local_flags);
906:
907: if (mask > 0)
908: {
909: *(Lisp_Object *)(idx + (char *) current_buffer)
910: = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
911: current_buffer->local_var_flags &= ~mask;
912: }
913: return sym;
914: }
915:
916: if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
917: XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
918: return sym;
919:
920: /* Get rid of this buffer's alist element, if any */
921:
922: tem = Fassq (sym, current_buffer->local_var_alist);
923: if (!NULL (tem))
924: current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist);
925:
926: /* Make sure symbol does not think it is set up for this buffer;
927: force it to look once again for this buffer's value */
928: {
929: Lisp_Object sv;
930: sv = XSYMBOL (sym)->value;
931: if (current_buffer == XBUFFER (XCONS (XCONS (sv)->cdr)->car))
932: XCONS (XCONS (sv)->cdr)->car = Qnil;
933: }
934:
935: return sym;
936: }
937:
938: /* Extract and set vector and string elements */
939:
940: DEFUN ("aref", Faref, Saref, 2, 2, 0,
941: "Return the element of ARRAY at index INDEX.\n\
942: ARRAY may be a vector or a string. INDEX starts at 0.")
943: (vector, idx)
944: register Lisp_Object vector;
945: Lisp_Object idx;
946: {
947: register int idxval;
948:
949: CHECK_NUMBER (idx, 1);
950: idxval = XINT (idx);
951: if (XTYPE (vector) != Lisp_Vector && XTYPE (vector) != Lisp_String)
952: vector = wrong_type_argument (Qarrayp, vector);
953: if (idxval < 0 || idxval >= XVECTOR (vector)->size)
954: args_out_of_range (vector, idx);
955: if (XTYPE (vector) == Lisp_Vector)
956: return XVECTOR (vector)->contents[idxval];
957: else
958: {
959: Lisp_Object val;
960: XFASTINT (val) = (unsigned char) XSTRING (vector)->data[idxval];
961: return val;
962: }
963: }
964:
965: DEFUN ("aset", Faset, Saset, 3, 3, 0,
966: "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
967: ARRAY may be a vector or a string. INDEX starts at 0.")
968: (vector, idx, newelt)
969: register Lisp_Object vector;
970: Lisp_Object idx, newelt;
971: {
972: register int idxval;
973:
974: CHECK_NUMBER (idx, 1);
975: idxval = XINT (idx);
976: if (XTYPE (vector) != Lisp_Vector && XTYPE (vector) != Lisp_String)
977: vector = wrong_type_argument (Qarrayp, vector);
978: if (idxval < 0 || idxval >= XVECTOR (vector)->size)
979: args_out_of_range (vector, idx);
980: CHECK_IMPURE (vector);
981:
982: if (XTYPE (vector) == Lisp_Vector)
983: XVECTOR (vector)->contents[idxval] = newelt;
984: else
985: XSTRING (vector)->data[idxval] = XINT (newelt);
986:
987: return newelt;
988: }
989:
990: Lisp_Object
991: Farray_length (vector)
992: register Lisp_Object vector;
993: {
994: register Lisp_Object size;
995: if (XTYPE (vector) != Lisp_Vector && XTYPE (vector) != Lisp_String)
996: vector = wrong_type_argument (Qarrayp, vector);
997: XFASTINT (size) = XVECTOR (vector)->size;
998: return size;
999: }
1000:
1001: /* Arithmetic functions */
1002:
1003: DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
1004: "T if two args, both numbers, are equal.")
1005: (num1, num2)
1006: register Lisp_Object num1, num2;
1007: {
1008: CHECK_NUMBER_COERCE_MARKER (num1, 0);
1009: CHECK_NUMBER_COERCE_MARKER (num2, 0);
1010:
1011: if (XINT (num1) == XINT (num2))
1012: return Qt;
1013: return Qnil;
1014: }
1015:
1016: DEFUN ("<", Flss, Slss, 2, 2, 0,
1017: "T if first arg is less than second arg. Both must be numbers.")
1018: (num1, num2)
1019: register Lisp_Object num1, num2;
1020: {
1021: CHECK_NUMBER_COERCE_MARKER (num1, 0);
1022: CHECK_NUMBER_COERCE_MARKER (num2, 0);
1023:
1024: if (XINT (num1) < XINT (num2))
1025: return Qt;
1026: return Qnil;
1027: }
1028:
1029: DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
1030: "T if first arg is greater than second arg. Both must be numbers.")
1031: (num1, num2)
1032: register Lisp_Object num1, num2;
1033: {
1034: CHECK_NUMBER_COERCE_MARKER (num1, 0);
1035: CHECK_NUMBER_COERCE_MARKER (num2, 0);
1036:
1037: if (XINT (num1) > XINT (num2))
1038: return Qt;
1039: return Qnil;
1040: }
1041:
1042: DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
1043: "T if first arg is less than or equal to second arg. Both must be numbers.")
1044: (num1, num2)
1045: register Lisp_Object num1, num2;
1046: {
1047: CHECK_NUMBER_COERCE_MARKER (num1, 0);
1048: CHECK_NUMBER_COERCE_MARKER (num2, 0);
1049:
1050: if (XINT (num1) <= XINT (num2))
1051: return Qt;
1052: return Qnil;
1053: }
1054:
1055: DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
1056: "T if first arg is greater than or equal to second arg. Both must be numbers.")
1057: (num1, num2)
1058: register Lisp_Object num1, num2;
1059: {
1060: CHECK_NUMBER_COERCE_MARKER (num1, 0);
1061: CHECK_NUMBER_COERCE_MARKER (num2, 0);
1062:
1063: if (XINT (num1) >= XINT (num2))
1064: return Qt;
1065: return Qnil;
1066: }
1067:
1068: DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
1069: "T if first arg is not equal to second arg. Both must be numbers.")
1070: (num1, num2)
1071: register Lisp_Object num1, num2;
1072: {
1073: CHECK_NUMBER_COERCE_MARKER (num1, 0);
1074: CHECK_NUMBER_COERCE_MARKER (num2, 0);
1075:
1076: if (XINT (num1) != XINT (num2))
1077: return Qt;
1078: return Qnil;
1079: }
1080:
1081: DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
1082: (num)
1083: register Lisp_Object num;
1084: {
1085: CHECK_NUMBER (num, 0);
1086:
1087: if (!XINT (num))
1088: return Qt;
1089: return Qnil;
1090: }
1091:
1092: DEFUN ("int-to-string", Fint_to_string, Sint_to_string, 1, 1, 0,
1093: "Convert INT to a string by printing it in decimal, with minus sign if negative.")
1094: (num)
1095: Lisp_Object num;
1096: {
1097: char buffer[20];
1098:
1099: CHECK_NUMBER (num, 0);
1100: sprintf (buffer, "%d", XINT (num));
1101: return build_string (buffer);
1102: }
1103:
1104: DEFUN ("string-to-int", Fstring_to_int, Sstring_to_int, 1, 1, 0,
1105: "Convert STRING to an integer by parsing it as a decimal number.")
1106: (str)
1107: register Lisp_Object str;
1108: {
1109: CHECK_STRING (str, 0);
1110: return make_number (atoi (XSTRING (str)->data));
1111: }
1112:
1113: enum arithop
1114: { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
1115:
1116: Lisp_Object
1117: arith_driver
1118: (code, nargs, args)
1119: enum arithop code;
1120: int nargs;
1121: register Lisp_Object *args;
1122: {
1123: register Lisp_Object val;
1124: register int argnum;
1125: register int accum;
1126: register int next;
1127:
1128: #ifdef SWITCH_ENUM_BUG
1129: switch ((int) code)
1130: #else
1131: switch (code)
1132: #endif
1133: {
1134: case Alogior:
1135: case Alogxor:
1136: case Aadd:
1137: case Asub:
1138: accum = 0; break;
1139: case Amult:
1140: accum = 1; break;
1141: case Alogand:
1142: accum = -1; break;
1143: }
1144:
1145: for (argnum = 0; argnum < nargs; argnum++)
1146: {
1147: val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
1148: CHECK_NUMBER_COERCE_MARKER (val, argnum);
1149: args[argnum] = val; /* runs into a compiler bug. */
1150: next = XINT (args[argnum]);
1151: #ifdef SWITCH_ENUM_BUG
1152: switch ((int) code)
1153: #else
1154: switch (code)
1155: #endif
1156: {
1157: case Aadd: accum += next; break;
1158: case Asub:
1159: if (!argnum && nargs != 1)
1160: next = - next;
1161: accum -= next;
1162: break;
1163: case Amult: accum *= next; break;
1164: case Adiv:
1165: if (!argnum) accum = next;
1166: else
1167: {
1168: /* Some systems fail to trap this right. */
1169: if (!XINT (next))
1170: while (1)
1171: Fsignal (Qarith_error, Qnil);
1172:
1173: accum /= next;
1174: }
1175: break;
1176: case Alogand: accum &= next; break;
1177: case Alogior: accum |= next; break;
1178: case Alogxor: accum ^= next; break;
1179: case Amax: if (!argnum || next > accum) accum = next; break;
1180: case Amin: if (!argnum || next < accum) accum = next; break;
1181: }
1182: }
1183:
1184: XSET (val, Lisp_Int, accum);
1185: return val;
1186: }
1187:
1188: DEFUN ("+", Fplus, Splus, 0, MANY, 0,
1189: "Return sum of any number of numbers.")
1190: (nargs, args)
1191: int nargs;
1192: Lisp_Object *args;
1193: {
1194: return arith_driver (Aadd, nargs, args);
1195: }
1196:
1197: DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
1198: "Negate number or subtract numbers.\n\
1199: With one arg, negates it. With more than one arg,\n\
1200: subtracts all but the first from the first.")
1201: (nargs, args)
1202: int nargs;
1203: Lisp_Object *args;
1204: {
1205: return arith_driver (Asub, nargs, args);
1206: }
1207:
1208: DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
1209: "Returns product of any number of numbers.")
1210: (nargs, args)
1211: int nargs;
1212: Lisp_Object *args;
1213: {
1214: return arith_driver (Amult, nargs, args);
1215: }
1216:
1217: DEFUN ("/", Fquo, Squo, 2, MANY, 0,
1218: "Returns first argument divided by rest of arguments.")
1219: (nargs, args)
1220: int nargs;
1221: Lisp_Object *args;
1222: {
1223: return arith_driver (Adiv, nargs, args);
1224: }
1225:
1226: DEFUN ("%", Frem, Srem, 2, 2, 0,
1227: "Returns remainder of first arg divided by second.")
1228: (num1, num2)
1229: register Lisp_Object num1, num2;
1230: {
1231: Lisp_Object val;
1232:
1233: CHECK_NUMBER (num1, 0);
1234: CHECK_NUMBER (num2, 1);
1235:
1236: /* Some systems fail to trap this right. */
1237: if (!XINT (num2))
1238: while (1)
1239: Fsignal (Qarith_error, Qnil);
1240:
1241: XSET (val, Lisp_Int, XINT (num1) % XINT (num2));
1242: return val;
1243: }
1244:
1245: DEFUN ("max", Fmax, Smax, 1, MANY, 0,
1246: "Return largest of all the arguments (which must be numbers.)")
1247: (nargs, args)
1248: int nargs;
1249: Lisp_Object *args;
1250: {
1251: return arith_driver (Amax, nargs, args);
1252: }
1253:
1254: DEFUN ("min", Fmin, Smin, 1, MANY, 0,
1255: "Return smallest of all the arguments (which must be numbers.)")
1256: (nargs, args)
1257: int nargs;
1258: Lisp_Object *args;
1259: {
1260: return arith_driver (Amin, nargs, args);
1261: }
1262:
1263: DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
1264: "Return bitwise and of all the arguments (numbers).")
1265: (nargs, args)
1266: int nargs;
1267: Lisp_Object *args;
1268: {
1269: return arith_driver (Alogand, nargs, args);
1270: }
1271:
1272: DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
1273: "Return bitwise or of all the arguments (numbers).")
1274: (nargs, args)
1275: int nargs;
1276: Lisp_Object *args;
1277: {
1278: return arith_driver (Alogior, nargs, args);
1279: }
1280:
1281: DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
1282: "Return bitwise exclusive-or of all the arguments (numbers).")
1283: (nargs, args)
1284: int nargs;
1285: Lisp_Object *args;
1286: {
1287: return arith_driver (Alogxor, nargs, args);
1288: }
1289:
1290: DEFUN ("ash", Fash, Sash, 2, 2, 0,
1291: "Return VALUE with its bits shifted left by COUNT.\n\
1292: If COUNT is negative, shifting is actually to the right.\n\
1293: In this case, the sign bit is duplicated.")
1294: (num1, num2)
1295: register Lisp_Object num1, num2;
1296: {
1297: register Lisp_Object val;
1298:
1299: CHECK_NUMBER (num1, 0);
1300: CHECK_NUMBER (num2, 1);
1301:
1302: if (XINT (num2) > 0)
1303: XSET (val, Lisp_Int, XINT (num1) << XFASTINT (num2));
1304: else
1305: XSET (val, Lisp_Int, XINT (num1) >> -XINT (num2));
1306: return val;
1307: }
1308:
1309: DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
1310: "Return VALUE with its bits shifted left by COUNT.\n\
1311: If COUNT is negative, shifting is actually to the right.\n\
1312: In this case, zeros are shifted in on the left.")
1313: (num1, num2)
1314: register Lisp_Object num1, num2;
1315: {
1316: register Lisp_Object val;
1317:
1318: CHECK_NUMBER (num1, 0);
1319: CHECK_NUMBER (num2, 1);
1320:
1321: if (XINT (num2) > 0)
1322: XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) << XFASTINT (num2));
1323: else
1324: XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) >> -XINT (num2));
1325: return val;
1326: }
1327:
1328: DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
1329: "Return NUMBER plus one.")
1330: (num)
1331: register Lisp_Object num;
1332: {
1333: CHECK_NUMBER_COERCE_MARKER (num, 0);
1334: XSETINT (num, XFASTINT (num) + 1);
1335: return num;
1336: }
1337:
1338: DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
1339: "Return NUMBER minus one.")
1340: (num)
1341: register Lisp_Object num;
1342: {
1343: CHECK_NUMBER_COERCE_MARKER (num, 0);
1344: XSETINT (num, XFASTINT (num) - 1);
1345: return num;
1346: }
1347:
1348: DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
1349: "Return the bitwise complement of ARG.")
1350: (num)
1351: register Lisp_Object num;
1352: {
1353: CHECK_NUMBER (num, 0);
1354: XSETINT (num, ~XFASTINT (num));
1355: return num;
1356: }
1357:
1358: void
1359: syms_of_data ()
1360: {
1361: Qquote = intern ("quote");
1362: Qlambda = intern ("lambda");
1363: Qsubr = intern ("subr");
1364: Qerror_conditions = intern ("error-conditions");
1365: Qerror_message = intern ("error-message");
1366: Qtop_level = intern ("top-level");
1367:
1368: Qerror = intern ("error");
1369: Qquit = intern ("quit");
1370: Qwrong_type_argument = intern ("wrong-type-argument");
1371: Qargs_out_of_range = intern ("args-out-of-range");
1372: Qvoid_function = intern ("void-function");
1373: Qvoid_variable = intern ("void-variable");
1374: Qsetting_constant = intern ("setting-constant");
1375: Qinvalid_read_syntax = intern ("invalid-read-syntax");
1376:
1377: Qinvalid_function = intern ("invalid-function");
1378: Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
1379: Qno_catch = intern ("no-catch");
1380: Qend_of_file = intern ("end-of-file");
1381: Qarith_error = intern ("arith-error");
1382: Qbeginning_of_buffer = intern ("beginning-of-buffer");
1383: Qend_of_buffer = intern ("end-of-buffer");
1384: Qbuffer_read_only = intern ("buffer-read-only");
1385:
1386: Qlistp = intern ("listp");
1387: Qconsp = intern ("consp");
1388: Qsymbolp = intern ("symbolp");
1389: Qintegerp = intern ("integerp");
1390: Qnatnump = intern ("natnump");
1391: Qstringp = intern ("stringp");
1392: Qarrayp = intern ("arrayp");
1393: Qsequencep = intern ("sequencep");
1394: Qbufferp = intern ("bufferp");
1395: Qvectorp = intern ("vectorp");
1396: Qchar_or_string_p = intern ("char-or-string-p");
1397: Qmarkerp = intern ("markerp");
1398: Qinteger_or_marker_p = intern ("integer-or-marker-p");
1399: Qboundp = intern ("boundp");
1400: Qfboundp = intern ("fboundp");
1401:
1402: Qcdr = intern ("cdr");
1403:
1404: /* ERROR is used as a signaler for random errors for which nothing else is right */
1405:
1406: Fput (Qerror, Qerror_conditions,
1407: Fcons (Qerror, Qnil));
1408: Fput (Qerror, Qerror_message,
1409: build_string ("error"));
1410:
1411: Fput (Qquit, Qerror_conditions,
1412: Fcons (Qquit, Qnil));
1413: Fput (Qquit, Qerror_message,
1414: build_string ("Quit"));
1415:
1416: Fput (Qwrong_type_argument, Qerror_conditions,
1417: Fcons (Qwrong_type_argument, Fcons (Qerror, Qnil)));
1418: Fput (Qwrong_type_argument, Qerror_message,
1419: build_string ("Wrong type argument"));
1420:
1421: Fput (Qargs_out_of_range, Qerror_conditions,
1422: Fcons (Qargs_out_of_range, Fcons (Qerror, Qnil)));
1423: Fput (Qargs_out_of_range, Qerror_message,
1424: build_string ("Args out of range"));
1425:
1426: Fput (Qvoid_function, Qerror_conditions,
1427: Fcons (Qvoid_function, Fcons (Qerror, Qnil)));
1428: Fput (Qvoid_function, Qerror_message,
1429: build_string ("Symbol's function definition is void"));
1430:
1431: Fput (Qvoid_variable, Qerror_conditions,
1432: Fcons (Qvoid_variable, Fcons (Qerror, Qnil)));
1433: Fput (Qvoid_variable, Qerror_message,
1434: build_string ("Symbol's value as variable is void"));
1435:
1436: Fput (Qsetting_constant, Qerror_conditions,
1437: Fcons (Qsetting_constant, Fcons (Qerror, Qnil)));
1438: Fput (Qsetting_constant, Qerror_message,
1439: build_string ("Attempt to set a constant symbol"));
1440:
1441: Fput (Qinvalid_read_syntax, Qerror_conditions,
1442: Fcons (Qinvalid_read_syntax, Fcons (Qerror, Qnil)));
1443: Fput (Qinvalid_read_syntax, Qerror_message,
1444: build_string ("Invalid read syntax"));
1445:
1446: Fput (Qinvalid_function, Qerror_conditions,
1447: Fcons (Qinvalid_function, Fcons (Qerror, Qnil)));
1448: Fput (Qinvalid_function, Qerror_message,
1449: build_string ("Invalid function"));
1450:
1451: Fput (Qwrong_number_of_arguments, Qerror_conditions,
1452: Fcons (Qwrong_number_of_arguments, Fcons (Qerror, Qnil)));
1453: Fput (Qwrong_number_of_arguments, Qerror_message,
1454: build_string ("Wrong number of arguments"));
1455:
1456: Fput (Qno_catch, Qerror_conditions,
1457: Fcons (Qno_catch, Fcons (Qerror, Qnil)));
1458: Fput (Qno_catch, Qerror_message,
1459: build_string ("No catch for tag"));
1460:
1461: Fput (Qend_of_file, Qerror_conditions,
1462: Fcons (Qend_of_file, Fcons (Qerror, Qnil)));
1463: Fput (Qend_of_file, Qerror_message,
1464: build_string ("End of file during parsing"));
1465:
1466: Fput (Qarith_error, Qerror_conditions,
1467: Fcons (Qarith_error, Fcons (Qerror, Qnil)));
1468: Fput (Qarith_error, Qerror_message,
1469: build_string ("Arithmetic error"));
1470:
1471: Fput (Qbeginning_of_buffer, Qerror_conditions,
1472: Fcons (Qbeginning_of_buffer, Fcons (Qerror, Qnil)));
1473: Fput (Qbeginning_of_buffer, Qerror_message,
1474: build_string ("Beginning of buffer"));
1475:
1476: Fput (Qend_of_buffer, Qerror_conditions,
1477: Fcons (Qend_of_buffer, Fcons (Qerror, Qnil)));
1478: Fput (Qend_of_buffer, Qerror_message,
1479: build_string ("End of buffer"));
1480:
1481: Fput (Qbuffer_read_only, Qerror_conditions,
1482: Fcons (Qbuffer_read_only, Fcons (Qerror, Qnil)));
1483: Fput (Qbuffer_read_only, Qerror_message,
1484: build_string ("Buffer is read-only"));
1485:
1486: staticpro (&Qnil);
1487: staticpro (&Qt);
1488: staticpro (&Qquote);
1489: staticpro (&Qlambda);
1490: staticpro (&Qsubr);
1491: staticpro (&Qunbound);
1492: staticpro (&Qerror_conditions);
1493: staticpro (&Qerror_message);
1494: staticpro (&Qtop_level);
1495:
1496: staticpro (&Qerror);
1497: staticpro (&Qquit);
1498: staticpro (&Qwrong_type_argument);
1499: staticpro (&Qargs_out_of_range);
1500: staticpro (&Qvoid_function);
1501: staticpro (&Qvoid_variable);
1502: staticpro (&Qsetting_constant);
1503: staticpro (&Qinvalid_read_syntax);
1504: staticpro (&Qwrong_number_of_arguments);
1505: staticpro (&Qinvalid_function);
1506: staticpro (&Qno_catch);
1507: staticpro (&Qend_of_file);
1508: staticpro (&Qarith_error);
1509: staticpro (&Qbeginning_of_buffer);
1510: staticpro (&Qend_of_buffer);
1511: staticpro (&Qbuffer_read_only);
1512:
1513: staticpro (&Qlistp);
1514: staticpro (&Qconsp);
1515: staticpro (&Qsymbolp);
1516: staticpro (&Qintegerp);
1517: staticpro (&Qnatnump);
1518: staticpro (&Qstringp);
1519: staticpro (&Qarrayp);
1520: staticpro (&Qsequencep);
1521: staticpro (&Qbufferp);
1522: staticpro (&Qvectorp);
1523: staticpro (&Qchar_or_string_p);
1524: staticpro (&Qmarkerp);
1525: staticpro (&Qinteger_or_marker_p);
1526: staticpro (&Qboundp);
1527: staticpro (&Qfboundp);
1528: staticpro (&Qcdr);
1529:
1530: defsubr (&Seq);
1531: defsubr (&Snull);
1532: defsubr (&Slistp);
1533: defsubr (&Snlistp);
1534: defsubr (&Sconsp);
1535: defsubr (&Satom);
1536: defsubr (&Sintegerp);
1537: defsubr (&Snatnump);
1538: defsubr (&Ssymbolp);
1539: defsubr (&Sstringp);
1540: defsubr (&Svectorp);
1541: defsubr (&Sarrayp);
1542: defsubr (&Ssequencep);
1543: defsubr (&Sbufferp);
1544: defsubr (&Smarkerp);
1545: defsubr (&Sinteger_or_marker_p);
1546: defsubr (&Ssubrp);
1547: defsubr (&Schar_or_string_p);
1548: defsubr (&Scar);
1549: defsubr (&Scdr);
1550: defsubr (&Scar_safe);
1551: defsubr (&Scdr_safe);
1552: defsubr (&Ssetcar);
1553: defsubr (&Ssetcdr);
1554: defsubr (&Ssymbol_function);
1555: defsubr (&Ssymbol_plist);
1556: defsubr (&Ssymbol_name);
1557: defsubr (&Smakunbound);
1558: defsubr (&Sfmakunbound);
1559: defsubr (&Sboundp);
1560: defsubr (&Sfboundp);
1561: defsubr (&Sfset);
1562: defsubr (&Ssetplist);
1563: defsubr (&Ssymbol_value);
1564: defsubr (&Sset);
1565: defsubr (&Sdefault_value);
1566: defsubr (&Sset_default);
1567: defsubr (&Ssetq_default);
1568: defsubr (&Smake_variable_buffer_local);
1569: defsubr (&Smake_local_variable);
1570: defsubr (&Skill_local_variable);
1571: defsubr (&Saref);
1572: defsubr (&Saset);
1573: defsubr (&Sint_to_string);
1574: defsubr (&Sstring_to_int);
1575: defsubr (&Seqlsign);
1576: defsubr (&Slss);
1577: defsubr (&Sgtr);
1578: defsubr (&Sleq);
1579: defsubr (&Sgeq);
1580: defsubr (&Sneq);
1581: defsubr (&Szerop);
1582: defsubr (&Splus);
1583: defsubr (&Sminus);
1584: defsubr (&Stimes);
1585: defsubr (&Squo);
1586: defsubr (&Srem);
1587: defsubr (&Smax);
1588: defsubr (&Smin);
1589: defsubr (&Slogand);
1590: defsubr (&Slogior);
1591: defsubr (&Slogxor);
1592: defsubr (&Slsh);
1593: defsubr (&Sash);
1594: defsubr (&Sadd1);
1595: defsubr (&Ssub1);
1596: defsubr (&Slognot);
1597: }
1598:
1599: arith_error (signo)
1600: int signo;
1601: {
1602: #ifdef USG
1603: /* USG systems forget handlers when they are used;
1604: must reestablish each time */
1605: signal (signo, arith_error);
1606: #endif /* USG */
1607: #ifdef VMS
1608: /* VMS systems are like USG. */
1609: signal (signo, arith_error);
1610: #endif /* VMS */
1611: #ifdef BSD4_1
1612: sigrelse (SIGFPE);
1613: #else /* not BSD4_1 */
1614: sigsetmask (SIGEMPTYMASK);
1615: #endif /* not BSD4_1 */
1616:
1617: while (1)
1618: Fsignal (Qarith_error, Qnil);
1619: }
1620:
1621: init_data ()
1622: {
1623: /* Don't do this if just dumping out.
1624: We don't want to call `signal' in this case
1625: so that we don't have trouble with dumping
1626: signal-delivering routines in an inconsistent state. */
1627: #ifndef CANNOT_DUMP
1628: if (!initialized)
1629: return;
1630: #endif /* CANNOT_DUMP */
1631: signal (SIGFPE, arith_error);
1632: #ifdef uts
1633: signal (SIGEMT, arith_error);
1634: #endif /* uts */
1635: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.