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