Mercurial > emacs
annotate src/data.c @ 4413:5a00cec8e9b0
(fill-region-as-paragraph): When we take one word
after the fill column, don't stop at period with just one space.
When checking whether at beginning of line, if no fill prefix,
ignore intervening whitespace.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Mon, 02 Aug 1993 05:55:56 +0000 |
parents | aecb99c65ab0 |
children | ba273b48143b |
rev | line source |
---|---|
298 | 1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. |
2961 | 2 Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc. |
298 | 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 #include <signal.h> | |
22 | |
23 #include "config.h" | |
24 #include "lisp.h" | |
336 | 25 #include "puresize.h" |
298 | 26 |
27 #ifndef standalone | |
28 #include "buffer.h" | |
29 #endif | |
30 | |
552 | 31 #include "syssignal.h" |
348 | 32 |
298 | 33 #ifdef LISP_FLOAT_TYPE |
2781
fde05936aebb
* lread.c, data.c: If STDC_HEADERS is #defined, include <stdlib.h>
Jim Blandy <jimb@redhat.com>
parents:
2647
diff
changeset
|
34 #ifdef STDC_HEADERS |
fde05936aebb
* lread.c, data.c: If STDC_HEADERS is #defined, include <stdlib.h>
Jim Blandy <jimb@redhat.com>
parents:
2647
diff
changeset
|
35 #include <stdlib.h> |
fde05936aebb
* lread.c, data.c: If STDC_HEADERS is #defined, include <stdlib.h>
Jim Blandy <jimb@redhat.com>
parents:
2647
diff
changeset
|
36 #endif |
298 | 37 #include <math.h> |
38 #endif /* LISP_FLOAT_TYPE */ | |
39 | |
40 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound; | |
41 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level; | |
42 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range; | |
648 | 43 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection; |
298 | 44 Lisp_Object Qsetting_constant, Qinvalid_read_syntax; |
45 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; | |
4036 | 46 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive; |
298 | 47 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; |
48 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qlistp, Qconsp; | |
49 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp; | |
50 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; | |
1293 | 51 Lisp_Object Qbuffer_or_string_p; |
298 | 52 Lisp_Object Qboundp, Qfboundp; |
53 Lisp_Object Qcdr; | |
54 | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
55 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error; |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
56 Lisp_Object Qoverflow_error, Qunderflow_error; |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
57 |
298 | 58 #ifdef LISP_FLOAT_TYPE |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
59 Lisp_Object Qfloatp; |
298 | 60 Lisp_Object Qnumberp, Qnumber_or_marker_p; |
61 #endif | |
62 | |
63 static Lisp_Object swap_in_symval_forwarding (); | |
64 | |
65 Lisp_Object | |
66 wrong_type_argument (predicate, value) | |
67 register Lisp_Object predicate, value; | |
68 { | |
69 register Lisp_Object tem; | |
70 do | |
71 { | |
72 if (!EQ (Vmocklisp_arguments, Qt)) | |
73 { | |
74 if (XTYPE (value) == Lisp_String && | |
75 (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p))) | |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
76 return Fstring_to_number (value); |
298 | 77 if (XTYPE (value) == Lisp_Int && EQ (predicate, Qstringp)) |
2429
96b55f2f19cd
Rename int-to-string to number-to-string, since it can handle
Jim Blandy <jimb@redhat.com>
parents:
2092
diff
changeset
|
78 return Fnumber_to_string (value); |
298 | 79 } |
80 value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil))); | |
81 tem = call1 (predicate, value); | |
82 } | |
490 | 83 while (NILP (tem)); |
298 | 84 return value; |
85 } | |
86 | |
87 pure_write_error () | |
88 { | |
89 error ("Attempt to modify read-only object"); | |
90 } | |
91 | |
92 void | |
93 args_out_of_range (a1, a2) | |
94 Lisp_Object a1, a2; | |
95 { | |
96 while (1) | |
97 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil))); | |
98 } | |
99 | |
100 void | |
101 args_out_of_range_3 (a1, a2, a3) | |
102 Lisp_Object a1, a2, a3; | |
103 { | |
104 while (1) | |
105 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil)))); | |
106 } | |
107 | |
108 Lisp_Object | |
109 make_number (num) | |
110 int num; | |
111 { | |
112 register Lisp_Object val; | |
113 XSET (val, Lisp_Int, num); | |
114 return val; | |
115 } | |
116 | |
117 /* On some machines, XINT needs a temporary location. | |
118 Here it is, in case it is needed. */ | |
119 | |
120 int sign_extend_temp; | |
121 | |
122 /* On a few machines, XINT can only be done by calling this. */ | |
123 | |
124 int | |
125 sign_extend_lisp_int (num) | |
126 int num; | |
127 { | |
128 if (num & (1 << (VALBITS - 1))) | |
129 return num | ((-1) << VALBITS); | |
130 else | |
131 return num & ((1 << VALBITS) - 1); | |
132 } | |
133 | |
134 /* Data type predicates */ | |
135 | |
136 DEFUN ("eq", Feq, Seq, 2, 2, 0, | |
137 "T if the two args are the same Lisp object.") | |
138 (obj1, obj2) | |
139 Lisp_Object obj1, obj2; | |
140 { | |
141 if (EQ (obj1, obj2)) | |
142 return Qt; | |
143 return Qnil; | |
144 } | |
145 | |
146 DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.") | |
147 (obj) | |
148 Lisp_Object obj; | |
149 { | |
490 | 150 if (NILP (obj)) |
298 | 151 return Qt; |
152 return Qnil; | |
153 } | |
154 | |
155 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.") | |
156 (obj) | |
157 Lisp_Object obj; | |
158 { | |
159 if (XTYPE (obj) == Lisp_Cons) | |
160 return Qt; | |
161 return Qnil; | |
162 } | |
163 | |
164 DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.") | |
165 (obj) | |
166 Lisp_Object obj; | |
167 { | |
168 if (XTYPE (obj) == Lisp_Cons) | |
169 return Qnil; | |
170 return Qt; | |
171 } | |
172 | |
173 DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.") | |
174 (obj) | |
175 Lisp_Object obj; | |
176 { | |
490 | 177 if (XTYPE (obj) == Lisp_Cons || NILP (obj)) |
298 | 178 return Qt; |
179 return Qnil; | |
180 } | |
181 | |
182 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.") | |
183 (obj) | |
184 Lisp_Object obj; | |
185 { | |
490 | 186 if (XTYPE (obj) == Lisp_Cons || NILP (obj)) |
298 | 187 return Qnil; |
188 return Qt; | |
189 } | |
190 | |
191 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.") | |
192 (obj) | |
193 Lisp_Object obj; | |
194 { | |
195 if (XTYPE (obj) == Lisp_Symbol) | |
196 return Qt; | |
197 return Qnil; | |
198 } | |
199 | |
200 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.") | |
201 (obj) | |
202 Lisp_Object obj; | |
203 { | |
204 if (XTYPE (obj) == Lisp_Vector) | |
205 return Qt; | |
206 return Qnil; | |
207 } | |
208 | |
209 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.") | |
210 (obj) | |
211 Lisp_Object obj; | |
212 { | |
213 if (XTYPE (obj) == Lisp_String) | |
214 return Qt; | |
215 return Qnil; | |
216 } | |
217 | |
218 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).") | |
219 (obj) | |
220 Lisp_Object obj; | |
221 { | |
222 if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String) | |
223 return Qt; | |
224 return Qnil; | |
225 } | |
226 | |
227 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0, | |
228 "T if OBJECT is a sequence (list or array).") | |
229 (obj) | |
230 register Lisp_Object obj; | |
231 { | |
490 | 232 if (CONSP (obj) || NILP (obj) || |
298 | 233 XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String) |
234 return Qt; | |
235 return Qnil; | |
236 } | |
237 | |
238 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.") | |
239 (obj) | |
240 Lisp_Object obj; | |
241 { | |
242 if (XTYPE (obj) == Lisp_Buffer) | |
243 return Qt; | |
244 return Qnil; | |
245 } | |
246 | |
247 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).") | |
248 (obj) | |
249 Lisp_Object obj; | |
250 { | |
251 if (XTYPE (obj) == Lisp_Marker) | |
252 return Qt; | |
253 return Qnil; | |
254 } | |
255 | |
256 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.") | |
257 (obj) | |
258 Lisp_Object obj; | |
259 { | |
260 if (XTYPE (obj) == Lisp_Subr) | |
261 return Qt; | |
262 return Qnil; | |
263 } | |
264 | |
1821
04fb1d3d6992
JimB's changes since January 18th
Jim Blandy <jimb@redhat.com>
parents:
1648
diff
changeset
|
265 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, |
04fb1d3d6992
JimB's changes since January 18th
Jim Blandy <jimb@redhat.com>
parents:
1648
diff
changeset
|
266 1, 1, 0, "T if OBJECT is a byte-compiled function object.") |
298 | 267 (obj) |
268 Lisp_Object obj; | |
269 { | |
270 if (XTYPE (obj) == Lisp_Compiled) | |
271 return Qt; | |
272 return Qnil; | |
273 } | |
274 | |
275 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.") | |
276 (obj) | |
277 register Lisp_Object obj; | |
278 { | |
279 if (XTYPE (obj) == Lisp_Int || XTYPE (obj) == Lisp_String) | |
280 return Qt; | |
281 return Qnil; | |
282 } | |
283 | |
284 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is a number.") | |
285 (obj) | |
286 Lisp_Object obj; | |
287 { | |
288 if (XTYPE (obj) == Lisp_Int) | |
289 return Qt; | |
290 return Qnil; | |
291 } | |
292 | |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
293 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0, |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
294 "T if OBJECT is an integer or a marker (editor pointer).") |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
295 (obj) |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
296 register Lisp_Object obj; |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
297 { |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
298 if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int) |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
299 return Qt; |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
300 return Qnil; |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
301 } |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
302 |
298 | 303 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.") |
304 (obj) | |
305 Lisp_Object obj; | |
306 { | |
307 if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0) | |
308 return Qt; | |
309 return Qnil; | |
310 } | |
311 | |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
312 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
313 "T if OBJECT is a number (floating point or integer).") |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
314 (obj) |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
315 Lisp_Object obj; |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
316 { |
1821
04fb1d3d6992
JimB's changes since January 18th
Jim Blandy <jimb@redhat.com>
parents:
1648
diff
changeset
|
317 if (NUMBERP (obj)) |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
318 return Qt; |
1821
04fb1d3d6992
JimB's changes since January 18th
Jim Blandy <jimb@redhat.com>
parents:
1648
diff
changeset
|
319 else |
04fb1d3d6992
JimB's changes since January 18th
Jim Blandy <jimb@redhat.com>
parents:
1648
diff
changeset
|
320 return Qnil; |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
321 } |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
322 |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
323 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
324 Snumber_or_marker_p, 1, 1, 0, |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
325 "T if OBJECT is a number or a marker.") |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
326 (obj) |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
327 Lisp_Object obj; |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
328 { |
1821
04fb1d3d6992
JimB's changes since January 18th
Jim Blandy <jimb@redhat.com>
parents:
1648
diff
changeset
|
329 if (NUMBERP (obj) |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
330 || XTYPE (obj) == Lisp_Marker) |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
331 return Qt; |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
332 return Qnil; |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
333 } |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
334 |
298 | 335 #ifdef LISP_FLOAT_TYPE |
336 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, | |
337 "T if OBJECT is a floating point number.") | |
338 (obj) | |
339 Lisp_Object obj; | |
340 { | |
341 if (XTYPE (obj) == Lisp_Float) | |
342 return Qt; | |
343 return Qnil; | |
344 } | |
345 #endif /* LISP_FLOAT_TYPE */ | |
346 | |
347 /* Extract and set components of lists */ | |
348 | |
349 DEFUN ("car", Fcar, Scar, 1, 1, 0, | |
350 "Return the car of CONSCELL. If arg is nil, return nil.\n\ | |
351 Error if arg is not nil and not a cons cell. See also `car-safe'.") | |
352 (list) | |
353 register Lisp_Object list; | |
354 { | |
355 while (1) | |
356 { | |
357 if (XTYPE (list) == Lisp_Cons) | |
358 return XCONS (list)->car; | |
359 else if (EQ (list, Qnil)) | |
360 return Qnil; | |
361 else | |
362 list = wrong_type_argument (Qlistp, list); | |
363 } | |
364 } | |
365 | |
366 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0, | |
367 "Return the car of OBJECT if it is a cons cell, or else nil.") | |
368 (object) | |
369 Lisp_Object object; | |
370 { | |
371 if (XTYPE (object) == Lisp_Cons) | |
372 return XCONS (object)->car; | |
373 else | |
374 return Qnil; | |
375 } | |
376 | |
377 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0, | |
378 "Return the cdr of CONSCELL. If arg is nil, return nil.\n\ | |
379 Error if arg is not nil and not a cons cell. See also `cdr-safe'.") | |
380 | |
381 (list) | |
382 register Lisp_Object list; | |
383 { | |
384 while (1) | |
385 { | |
386 if (XTYPE (list) == Lisp_Cons) | |
387 return XCONS (list)->cdr; | |
388 else if (EQ (list, Qnil)) | |
389 return Qnil; | |
390 else | |
391 list = wrong_type_argument (Qlistp, list); | |
392 } | |
393 } | |
394 | |
395 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0, | |
396 "Return the cdr of OBJECT if it is a cons cell, or else nil.") | |
397 (object) | |
398 Lisp_Object object; | |
399 { | |
400 if (XTYPE (object) == Lisp_Cons) | |
401 return XCONS (object)->cdr; | |
402 else | |
403 return Qnil; | |
404 } | |
405 | |
406 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0, | |
407 "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.") | |
408 (cell, newcar) | |
409 register Lisp_Object cell, newcar; | |
410 { | |
411 if (XTYPE (cell) != Lisp_Cons) | |
412 cell = wrong_type_argument (Qconsp, cell); | |
413 | |
414 CHECK_IMPURE (cell); | |
415 XCONS (cell)->car = newcar; | |
416 return newcar; | |
417 } | |
418 | |
419 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0, | |
420 "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.") | |
421 (cell, newcdr) | |
422 register Lisp_Object cell, newcdr; | |
423 { | |
424 if (XTYPE (cell) != Lisp_Cons) | |
425 cell = wrong_type_argument (Qconsp, cell); | |
426 | |
427 CHECK_IMPURE (cell); | |
428 XCONS (cell)->cdr = newcdr; | |
429 return newcdr; | |
430 } | |
431 | |
432 /* Extract and set components of symbols */ | |
433 | |
434 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.") | |
435 (sym) | |
436 register Lisp_Object sym; | |
437 { | |
438 Lisp_Object valcontents; | |
439 CHECK_SYMBOL (sym, 0); | |
440 | |
441 valcontents = XSYMBOL (sym)->value; | |
442 | |
443 #ifdef SWITCH_ENUM_BUG | |
444 switch ((int) XTYPE (valcontents)) | |
445 #else | |
446 switch (XTYPE (valcontents)) | |
447 #endif | |
448 { | |
449 case Lisp_Buffer_Local_Value: | |
450 case Lisp_Some_Buffer_Local_Value: | |
451 valcontents = swap_in_symval_forwarding (sym, valcontents); | |
452 } | |
453 | |
454 return (XTYPE (valcontents) == Lisp_Void || EQ (valcontents, Qunbound) | |
455 ? Qnil : Qt); | |
456 } | |
457 | |
458 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.") | |
459 (sym) | |
460 register Lisp_Object sym; | |
461 { | |
462 CHECK_SYMBOL (sym, 0); | |
463 return (XTYPE (XSYMBOL (sym)->function) == Lisp_Void | |
464 || EQ (XSYMBOL (sym)->function, Qunbound)) | |
465 ? Qnil : Qt; | |
466 } | |
467 | |
468 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.") | |
469 (sym) | |
470 register Lisp_Object sym; | |
471 { | |
472 CHECK_SYMBOL (sym, 0); | |
490 | 473 if (NILP (sym) || EQ (sym, Qt)) |
298 | 474 return Fsignal (Qsetting_constant, Fcons (sym, Qnil)); |
475 Fset (sym, Qunbound); | |
476 return sym; | |
477 } | |
478 | |
479 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.") | |
480 (sym) | |
481 register Lisp_Object sym; | |
482 { | |
483 CHECK_SYMBOL (sym, 0); | |
484 XSYMBOL (sym)->function = Qunbound; | |
485 return sym; | |
486 } | |
487 | |
488 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, | |
489 "Return SYMBOL's function definition. Error if that is void.") | |
648 | 490 (symbol) |
491 register Lisp_Object symbol; | |
298 | 492 { |
648 | 493 CHECK_SYMBOL (symbol, 0); |
494 if (EQ (XSYMBOL (symbol)->function, Qunbound)) | |
495 return Fsignal (Qvoid_function, Fcons (symbol, Qnil)); | |
496 return XSYMBOL (symbol)->function; | |
298 | 497 } |
498 | |
499 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.") | |
500 (sym) | |
501 register Lisp_Object sym; | |
502 { | |
503 CHECK_SYMBOL (sym, 0); | |
504 return XSYMBOL (sym)->plist; | |
505 } | |
506 | |
507 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.") | |
508 (sym) | |
509 register Lisp_Object sym; | |
510 { | |
511 register Lisp_Object name; | |
512 | |
513 CHECK_SYMBOL (sym, 0); | |
514 XSET (name, Lisp_String, XSYMBOL (sym)->name); | |
515 return name; | |
516 } | |
517 | |
518 DEFUN ("fset", Ffset, Sfset, 2, 2, 0, | |
519 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.") | |
520 (sym, newdef) | |
521 register Lisp_Object sym, newdef; | |
522 { | |
523 CHECK_SYMBOL (sym, 0); | |
2647
425c4138af31
* data.c (Ffset): Refuse to set the function value of t or nil.
Jim Blandy <jimb@redhat.com>
parents:
2606
diff
changeset
|
524 |
490 | 525 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound)) |
298 | 526 Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), |
527 Vautoload_queue); | |
528 XSYMBOL (sym)->function = newdef; | |
529 return newdef; | |
530 } | |
531 | |
2606
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
532 /* This name should be removed once it is eliminated from elsewhere. */ |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
533 |
2565
c1a1557bffde
(Fdefine_function): Changed name back to Fdefalias, so we get things
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2548
diff
changeset
|
534 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0, |
2548
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
535 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\ |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
536 Associates the function with the current load file, if any.") |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
537 (sym, newdef) |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
538 register Lisp_Object sym, newdef; |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
539 { |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
540 CHECK_SYMBOL (sym, 0); |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
541 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound)) |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
542 Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
543 Vautoload_queue); |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
544 XSYMBOL (sym)->function = newdef; |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
545 LOADHIST_ATTACH (sym); |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
546 return newdef; |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
547 } |
b66eeded6afc
(Fdefine_function): New function.
Richard M. Stallman <rms@gnu.org>
parents:
2515
diff
changeset
|
548 |
2606
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
549 DEFUN ("define-function", Fdefine_function, Sdefine_function, 2, 2, 0, |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
550 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\ |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
551 Associates the function with the current load file, if any.") |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
552 (sym, newdef) |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
553 register Lisp_Object sym, newdef; |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
554 { |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
555 CHECK_SYMBOL (sym, 0); |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
556 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound)) |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
557 Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
558 Vautoload_queue); |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
559 XSYMBOL (sym)->function = newdef; |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
560 LOADHIST_ATTACH (sym); |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
561 return newdef; |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
562 } |
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
563 |
298 | 564 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0, |
565 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.") | |
566 (sym, newplist) | |
567 register Lisp_Object sym, newplist; | |
568 { | |
569 CHECK_SYMBOL (sym, 0); | |
570 XSYMBOL (sym)->plist = newplist; | |
571 return newplist; | |
572 } | |
648 | 573 |
298 | 574 |
575 /* Getting and setting values of symbols */ | |
576 | |
577 /* Given the raw contents of a symbol value cell, | |
578 return the Lisp value of the symbol. | |
579 This does not handle buffer-local variables; use | |
580 swap_in_symval_forwarding for that. */ | |
581 | |
582 Lisp_Object | |
583 do_symval_forwarding (valcontents) | |
584 register Lisp_Object valcontents; | |
585 { | |
586 register Lisp_Object val; | |
587 #ifdef SWITCH_ENUM_BUG | |
588 switch ((int) XTYPE (valcontents)) | |
589 #else | |
590 switch (XTYPE (valcontents)) | |
591 #endif | |
592 { | |
593 case Lisp_Intfwd: | |
594 XSET (val, Lisp_Int, *XINTPTR (valcontents)); | |
595 return val; | |
596 | |
597 case Lisp_Boolfwd: | |
598 if (*XINTPTR (valcontents)) | |
599 return Qt; | |
600 return Qnil; | |
601 | |
602 case Lisp_Objfwd: | |
603 return *XOBJFWD (valcontents); | |
604 | |
605 case Lisp_Buffer_Objfwd: | |
606 return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer); | |
607 } | |
608 return valcontents; | |
609 } | |
610 | |
611 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell | |
612 of SYM. If SYM is buffer-local, VALCONTENTS should be the | |
613 buffer-independent contents of the value cell: forwarded just one | |
614 step past the buffer-localness. */ | |
615 | |
616 void | |
617 store_symval_forwarding (sym, valcontents, newval) | |
618 Lisp_Object sym; | |
619 register Lisp_Object valcontents, newval; | |
620 { | |
621 #ifdef SWITCH_ENUM_BUG | |
622 switch ((int) XTYPE (valcontents)) | |
623 #else | |
624 switch (XTYPE (valcontents)) | |
625 #endif | |
626 { | |
627 case Lisp_Intfwd: | |
628 CHECK_NUMBER (newval, 1); | |
629 *XINTPTR (valcontents) = XINT (newval); | |
630 break; | |
631 | |
632 case Lisp_Boolfwd: | |
490 | 633 *XINTPTR (valcontents) = NILP(newval) ? 0 : 1; |
298 | 634 break; |
635 | |
636 case Lisp_Objfwd: | |
637 *XOBJFWD (valcontents) = newval; | |
638 break; | |
639 | |
640 case Lisp_Buffer_Objfwd: | |
1002
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
641 { |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
642 unsigned int offset = XUINT (valcontents); |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
643 Lisp_Object type = |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
644 *(Lisp_Object *)(offset + (char *)&buffer_local_types); |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
645 |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
646 if (! NILP (type) && ! NILP (newval) |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
647 && XTYPE (newval) != XINT (type)) |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
648 buffer_slot_type_mismatch (valcontents, newval); |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
649 |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
650 *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer) |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
651 = newval; |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
652 break; |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
653 } |
298 | 654 |
655 default: | |
656 valcontents = XSYMBOL (sym)->value; | |
657 if (XTYPE (valcontents) == Lisp_Buffer_Local_Value | |
658 || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) | |
659 XCONS (XSYMBOL (sym)->value)->car = newval; | |
660 else | |
661 XSYMBOL (sym)->value = newval; | |
662 } | |
663 } | |
664 | |
665 /* Set up the buffer-local symbol SYM for validity in the current | |
666 buffer. VALCONTENTS is the contents of its value cell. | |
667 Return the value forwarded one step past the buffer-local indicator. */ | |
668 | |
669 static Lisp_Object | |
670 swap_in_symval_forwarding (sym, valcontents) | |
671 Lisp_Object sym, valcontents; | |
672 { | |
673 /* valcontents is a list | |
674 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)). | |
675 | |
676 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's | |
1263
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
677 local_var_alist, that being the element whose car is this |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
678 variable. Or it can be a pointer to the |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
679 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
680 an element in its alist for this variable. |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
681 |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
682 If the current buffer is not BUFFER, we store the current |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
683 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
684 appropriate alist element for the buffer now current and set up |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
685 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
686 element, and store into BUFFER. |
3790dfbefb30
* data.c (swap_in_symval_forwarding): Formatting tweaked.
Jim Blandy <jimb@redhat.com>
parents:
1253
diff
changeset
|
687 |
298 | 688 Note that REALVALUE can be a forwarding pointer. */ |
689 | |
690 register Lisp_Object tem1; | |
691 tem1 = XCONS (XCONS (valcontents)->cdr)->car; | |
692 | |
490 | 693 if (NILP (tem1) || current_buffer != XBUFFER (tem1)) |
298 | 694 { |
695 tem1 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car; | |
696 Fsetcdr (tem1, do_symval_forwarding (XCONS (valcontents)->car)); | |
697 tem1 = assq_no_quit (sym, current_buffer->local_var_alist); | |
490 | 698 if (NILP (tem1)) |
298 | 699 tem1 = XCONS (XCONS (valcontents)->cdr)->cdr; |
700 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1; | |
701 XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer); | |
702 store_symval_forwarding (sym, XCONS (valcontents)->car, Fcdr (tem1)); | |
703 } | |
704 return XCONS (valcontents)->car; | |
705 } | |
706 | |
514 | 707 /* Find the value of a symbol, returning Qunbound if it's not bound. |
708 This is helpful for code which just wants to get a variable's value | |
709 if it has one, without signalling an error. | |
710 Note that it must not be possible to quit | |
711 within this function. Great care is required for this. */ | |
298 | 712 |
514 | 713 Lisp_Object |
714 find_symbol_value (sym) | |
298 | 715 Lisp_Object sym; |
716 { | |
717 register Lisp_Object valcontents, tem1; | |
718 register Lisp_Object val; | |
719 CHECK_SYMBOL (sym, 0); | |
720 valcontents = XSYMBOL (sym)->value; | |
721 | |
722 retry: | |
723 #ifdef SWITCH_ENUM_BUG | |
724 switch ((int) XTYPE (valcontents)) | |
725 #else | |
726 switch (XTYPE (valcontents)) | |
727 #endif | |
728 { | |
729 case Lisp_Buffer_Local_Value: | |
730 case Lisp_Some_Buffer_Local_Value: | |
731 valcontents = swap_in_symval_forwarding (sym, valcontents); | |
732 goto retry; | |
733 | |
734 case Lisp_Intfwd: | |
735 XSET (val, Lisp_Int, *XINTPTR (valcontents)); | |
736 return val; | |
737 | |
738 case Lisp_Boolfwd: | |
739 if (*XINTPTR (valcontents)) | |
740 return Qt; | |
741 return Qnil; | |
742 | |
743 case Lisp_Objfwd: | |
744 return *XOBJFWD (valcontents); | |
745 | |
746 case Lisp_Buffer_Objfwd: | |
747 return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer); | |
748 | |
749 case Lisp_Void: | |
514 | 750 return Qunbound; |
298 | 751 } |
752 | |
753 return valcontents; | |
754 } | |
755 | |
514 | 756 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0, |
757 "Return SYMBOL's value. Error if that is void.") | |
758 (sym) | |
759 Lisp_Object sym; | |
760 { | |
761 Lisp_Object val = find_symbol_value (sym); | |
762 | |
763 if (EQ (val, Qunbound)) | |
764 return Fsignal (Qvoid_variable, Fcons (sym, Qnil)); | |
765 else | |
766 return val; | |
767 } | |
768 | |
298 | 769 DEFUN ("set", Fset, Sset, 2, 2, 0, |
770 "Set SYMBOL's value to NEWVAL, and return NEWVAL.") | |
771 (sym, newval) | |
772 register Lisp_Object sym, newval; | |
773 { | |
774 int voide = (XTYPE (newval) == Lisp_Void || EQ (newval, Qunbound)); | |
775 | |
776 #ifndef RTPC_REGISTER_BUG | |
777 register Lisp_Object valcontents, tem1, current_alist_element; | |
778 #else /* RTPC_REGISTER_BUG */ | |
779 register Lisp_Object tem1; | |
780 Lisp_Object valcontents, current_alist_element; | |
781 #endif /* RTPC_REGISTER_BUG */ | |
782 | |
783 CHECK_SYMBOL (sym, 0); | |
490 | 784 if (NILP (sym) || EQ (sym, Qt)) |
298 | 785 return Fsignal (Qsetting_constant, Fcons (sym, Qnil)); |
786 valcontents = XSYMBOL (sym)->value; | |
787 | |
788 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) | |
789 { | |
790 register int idx = XUINT (valcontents); | |
791 register int mask = *(int *)(idx + (char *) &buffer_local_flags); | |
792 if (mask > 0) | |
793 current_buffer->local_var_flags |= mask; | |
794 } | |
795 | |
733 | 796 else if (XTYPE (valcontents) == Lisp_Buffer_Local_Value |
797 || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) | |
298 | 798 { |
733 | 799 /* valcontents is actually a pointer to a cons heading something like: |
800 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE). | |
801 | |
802 BUFFER is the last buffer for which this symbol's value was | |
803 made up to date. | |
298 | 804 |
733 | 805 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's |
806 local_var_alist, that being the element whose car is this | |
807 variable. Or it can be a pointer to the | |
808 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not | |
809 have an element in its alist for this variable (that is, if | |
810 BUFFER sees the default value of this variable). | |
811 | |
812 If we want to examine or set the value and BUFFER is current, | |
813 we just examine or set REALVALUE. If BUFFER is not current, we | |
814 store the current REALVALUE value into CURRENT-ALIST-ELEMENT, | |
815 then find the appropriate alist element for the buffer now | |
816 current and set up CURRENT-ALIST-ELEMENT. Then we set | |
817 REALVALUE out of that element, and store into BUFFER. | |
298 | 818 |
733 | 819 If we are setting the variable and the current buffer does |
820 not have an alist entry for this variable, an alist entry is | |
821 created. | |
822 | |
823 Note that REALVALUE can be a forwarding pointer. Each time | |
824 it is examined or set, forwarding must be done. */ | |
825 | |
826 /* What value are we caching right now? */ | |
827 current_alist_element = | |
828 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car; | |
298 | 829 |
733 | 830 /* If the current buffer is not the buffer whose binding is |
831 currently cached, or if it's a Lisp_Buffer_Local_Value and | |
832 we're looking at the default value, the cache is invalid; we | |
833 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */ | |
834 if ((current_buffer | |
835 != XBUFFER (XCONS (XCONS (valcontents)->cdr)->car)) | |
836 || (XTYPE (valcontents) == Lisp_Buffer_Local_Value | |
1508
768d4c10c2bf
* data.c (Fset): See if current_alist_element points to itself
Jim Blandy <jimb@redhat.com>
parents:
1293
diff
changeset
|
837 && EQ (XCONS (current_alist_element)->car, |
768d4c10c2bf
* data.c (Fset): See if current_alist_element points to itself
Jim Blandy <jimb@redhat.com>
parents:
1293
diff
changeset
|
838 current_alist_element))) |
298 | 839 { |
733 | 840 /* Write out the cached value for the old buffer; copy it |
841 back to its alist element. This works if the current | |
842 buffer only sees the default value, too. */ | |
843 Fsetcdr (current_alist_element, | |
844 do_symval_forwarding (XCONS (valcontents)->car)); | |
298 | 845 |
733 | 846 /* Find the new value for CURRENT-ALIST-ELEMENT. */ |
298 | 847 tem1 = Fassq (sym, current_buffer->local_var_alist); |
490 | 848 if (NILP (tem1)) |
733 | 849 { |
850 /* This buffer still sees the default value. */ | |
851 | |
852 /* If the variable is a Lisp_Some_Buffer_Local_Value, | |
853 make CURRENT-ALIST-ELEMENT point to itself, | |
854 indicating that we're seeing the default value. */ | |
855 if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) | |
856 tem1 = XCONS (XCONS (valcontents)->cdr)->cdr; | |
857 | |
858 /* If it's a Lisp_Buffer_Local_Value, give this buffer a | |
859 new assoc for a local value and set | |
860 CURRENT-ALIST-ELEMENT to point to that. */ | |
861 else | |
862 { | |
863 tem1 = Fcons (sym, Fcdr (current_alist_element)); | |
864 current_buffer->local_var_alist = | |
865 Fcons (tem1, current_buffer->local_var_alist); | |
866 } | |
867 } | |
868 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */ | |
298 | 869 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1; |
733 | 870 |
871 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */ | |
872 XSET (XCONS (XCONS (valcontents)->cdr)->car, | |
873 Lisp_Buffer, current_buffer); | |
298 | 874 } |
875 valcontents = XCONS (valcontents)->car; | |
876 } | |
733 | 877 |
298 | 878 /* If storing void (making the symbol void), forward only through |
879 buffer-local indicator, not through Lisp_Objfwd, etc. */ | |
880 if (voide) | |
881 store_symval_forwarding (sym, Qnil, newval); | |
882 else | |
883 store_symval_forwarding (sym, valcontents, newval); | |
733 | 884 |
298 | 885 return newval; |
886 } | |
887 | |
888 /* Access or set a buffer-local symbol's default value. */ | |
889 | |
890 /* Return the default value of SYM, but don't check for voidness. | |
891 Return Qunbound or a Lisp_Void object if it is void. */ | |
892 | |
893 Lisp_Object | |
894 default_value (sym) | |
895 Lisp_Object sym; | |
896 { | |
897 register Lisp_Object valcontents; | |
898 | |
899 CHECK_SYMBOL (sym, 0); | |
900 valcontents = XSYMBOL (sym)->value; | |
901 | |
902 /* For a built-in buffer-local variable, get the default value | |
903 rather than letting do_symval_forwarding get the current value. */ | |
904 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) | |
905 { | |
906 register int idx = XUINT (valcontents); | |
907 | |
908 if (*(int *) (idx + (char *) &buffer_local_flags) != 0) | |
909 return *(Lisp_Object *)(idx + (char *) &buffer_defaults); | |
910 } | |
911 | |
912 /* Handle user-created local variables. */ | |
913 if (XTYPE (valcontents) == Lisp_Buffer_Local_Value | |
914 || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) | |
915 { | |
916 /* If var is set up for a buffer that lacks a local value for it, | |
917 the current value is nominally the default value. | |
918 But the current value slot may be more up to date, since | |
919 ordinary setq stores just that slot. So use that. */ | |
920 Lisp_Object current_alist_element, alist_element_car; | |
921 current_alist_element | |
922 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car; | |
923 alist_element_car = XCONS (current_alist_element)->car; | |
924 if (EQ (alist_element_car, current_alist_element)) | |
925 return do_symval_forwarding (XCONS (valcontents)->car); | |
926 else | |
927 return XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr; | |
928 } | |
929 /* For other variables, get the current value. */ | |
930 return do_symval_forwarding (valcontents); | |
931 } | |
932 | |
933 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0, | |
934 "Return T if SYMBOL has a non-void default value.\n\ | |
935 This is the value that is seen in buffers that do not have their own values\n\ | |
936 for this variable.") | |
937 (sym) | |
938 Lisp_Object sym; | |
939 { | |
940 register Lisp_Object value; | |
941 | |
942 value = default_value (sym); | |
943 return (XTYPE (value) == Lisp_Void || EQ (value, Qunbound) | |
944 ? Qnil : Qt); | |
945 } | |
946 | |
947 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0, | |
948 "Return SYMBOL's default value.\n\ | |
949 This is the value that is seen in buffers that do not have their own values\n\ | |
950 for this variable. The default value is meaningful for variables with\n\ | |
951 local bindings in certain buffers.") | |
952 (sym) | |
953 Lisp_Object sym; | |
954 { | |
955 register Lisp_Object value; | |
956 | |
957 value = default_value (sym); | |
958 if (XTYPE (value) == Lisp_Void || EQ (value, Qunbound)) | |
959 return Fsignal (Qvoid_variable, Fcons (sym, Qnil)); | |
960 return value; | |
961 } | |
962 | |
963 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, | |
964 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\ | |
965 The default value is seen in buffers that do not have their own values\n\ | |
966 for this variable.") | |
967 (sym, value) | |
968 Lisp_Object sym, value; | |
969 { | |
970 register Lisp_Object valcontents, current_alist_element, alist_element_buffer; | |
971 | |
972 CHECK_SYMBOL (sym, 0); | |
973 valcontents = XSYMBOL (sym)->value; | |
974 | |
975 /* Handle variables like case-fold-search that have special slots | |
976 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value | |
977 variables. */ | |
978 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) | |
979 { | |
980 register int idx = XUINT (valcontents); | |
981 #ifndef RTPC_REGISTER_BUG | |
982 register struct buffer *b; | |
983 #else | |
984 struct buffer *b; | |
985 #endif | |
986 register int mask = *(int *) (idx + (char *) &buffer_local_flags); | |
987 | |
988 if (mask > 0) | |
989 { | |
990 *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value; | |
991 for (b = all_buffers; b; b = b->next) | |
992 if (!(b->local_var_flags & mask)) | |
993 *(Lisp_Object *)(idx + (char *) b) = value; | |
994 } | |
995 return value; | |
996 } | |
997 | |
998 if (XTYPE (valcontents) != Lisp_Buffer_Local_Value && | |
999 XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value) | |
1000 return Fset (sym, value); | |
1001 | |
1002 /* Store new value into the DEFAULT-VALUE slot */ | |
1003 XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr = value; | |
1004 | |
1005 /* If that slot is current, we must set the REALVALUE slot too */ | |
1006 current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car; | |
1007 alist_element_buffer = Fcar (current_alist_element); | |
1008 if (EQ (alist_element_buffer, current_alist_element)) | |
1009 store_symval_forwarding (sym, XCONS (valcontents)->car, value); | |
1010 | |
1011 return value; | |
1012 } | |
1013 | |
1014 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0, | |
1015 "\ | |
1016 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\ | |
1017 VAL is evaluated; SYM is not. The default value is seen in buffers that do\n\ | |
1018 not have their own values for this variable.") | |
1019 (args) | |
1020 Lisp_Object args; | |
1021 { | |
1022 register Lisp_Object args_left; | |
1023 register Lisp_Object val, sym; | |
1024 struct gcpro gcpro1; | |
1025 | |
490 | 1026 if (NILP (args)) |
298 | 1027 return Qnil; |
1028 | |
1029 args_left = args; | |
1030 GCPRO1 (args); | |
1031 | |
1032 do | |
1033 { | |
1034 val = Feval (Fcar (Fcdr (args_left))); | |
1035 sym = Fcar (args_left); | |
1036 Fset_default (sym, val); | |
1037 args_left = Fcdr (Fcdr (args_left)); | |
1038 } | |
490 | 1039 while (!NILP (args_left)); |
298 | 1040 |
1041 UNGCPRO; | |
1042 return val; | |
1043 } | |
1044 | |
1278
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1045 /* Lisp functions for creating and removing buffer-local variables. */ |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1046 |
298 | 1047 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local, |
1048 1, 1, "vMake Variable Buffer Local: ", | |
1049 "Make VARIABLE have a separate value for each buffer.\n\ | |
1050 At any time, the value for the current buffer is in effect.\n\ | |
1051 There is also a default value which is seen in any buffer which has not yet\n\ | |
1052 set its own value.\n\ | |
1053 Using `set' or `setq' to set the variable causes it to have a separate value\n\ | |
1054 for the current buffer if it was previously using the default value.\n\ | |
1055 The function `default-value' gets the default value and `set-default' sets it.") | |
1056 (sym) | |
1057 register Lisp_Object sym; | |
1058 { | |
1059 register Lisp_Object tem, valcontents; | |
1060 | |
1061 CHECK_SYMBOL (sym, 0); | |
1062 | |
1063 if (EQ (sym, Qnil) || EQ (sym, Qt)) | |
1064 error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data); | |
1065 | |
1066 valcontents = XSYMBOL (sym)->value; | |
1067 if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) || | |
1068 (XTYPE (valcontents) == Lisp_Buffer_Objfwd)) | |
1069 return sym; | |
1070 if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) | |
1071 { | |
1072 XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value); | |
1073 return sym; | |
1074 } | |
1075 if (EQ (valcontents, Qunbound)) | |
1076 XSYMBOL (sym)->value = Qnil; | |
1077 tem = Fcons (Qnil, Fsymbol_value (sym)); | |
1078 XCONS (tem)->car = tem; | |
1079 XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Fcurrent_buffer (), tem)); | |
1080 XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value); | |
1081 return sym; | |
1082 } | |
1083 | |
1084 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable, | |
1085 1, 1, "vMake Local Variable: ", | |
1086 "Make VARIABLE have a separate value in the current buffer.\n\ | |
1087 Other buffers will continue to share a common default value.\n\ | |
1088 See also `make-variable-buffer-local'.\n\n\ | |
1089 If the variable is already arranged to become local when set,\n\ | |
1090 this function causes a local value to exist for this buffer,\n\ | |
1091 just as if the variable were set.") | |
1092 (sym) | |
1093 register Lisp_Object sym; | |
1094 { | |
1095 register Lisp_Object tem, valcontents; | |
1096 | |
1097 CHECK_SYMBOL (sym, 0); | |
1098 | |
1099 if (EQ (sym, Qnil) || EQ (sym, Qt)) | |
1100 error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data); | |
1101 | |
1102 valcontents = XSYMBOL (sym)->value; | |
1103 if (XTYPE (valcontents) == Lisp_Buffer_Local_Value | |
1104 || XTYPE (valcontents) == Lisp_Buffer_Objfwd) | |
1105 { | |
1106 tem = Fboundp (sym); | |
1107 | |
1108 /* Make sure the symbol has a local value in this particular buffer, | |
1109 by setting it to the same value it already has. */ | |
1110 Fset (sym, (EQ (tem, Qt) ? Fsymbol_value (sym) : Qunbound)); | |
1111 return sym; | |
1112 } | |
1113 /* Make sure sym is set up to hold per-buffer values */ | |
1114 if (XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value) | |
1115 { | |
1116 if (EQ (valcontents, Qunbound)) | |
1117 XSYMBOL (sym)->value = Qnil; | |
1118 tem = Fcons (Qnil, do_symval_forwarding (valcontents)); | |
1119 XCONS (tem)->car = tem; | |
1120 XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Qnil, tem)); | |
1121 XSETTYPE (XSYMBOL (sym)->value, Lisp_Some_Buffer_Local_Value); | |
1122 } | |
1123 /* Make sure this buffer has its own value of sym */ | |
1124 tem = Fassq (sym, current_buffer->local_var_alist); | |
490 | 1125 if (NILP (tem)) |
298 | 1126 { |
1127 current_buffer->local_var_alist | |
1128 = Fcons (Fcons (sym, XCONS (XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->cdr)->cdr), | |
1129 current_buffer->local_var_alist); | |
1130 | |
1131 /* Make sure symbol does not think it is set up for this buffer; | |
1132 force it to look once again for this buffer's value */ | |
1133 { | |
1134 /* This local variable avoids "expression too complex" on IBM RT. */ | |
1135 Lisp_Object xs; | |
1136 | |
1137 xs = XSYMBOL (sym)->value; | |
1138 if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car)) | |
1139 XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil; | |
1140 } | |
1278
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1141 } |
298 | 1142 |
1278
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1143 /* If the symbol forwards into a C variable, then swap in the |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1144 variable for this buffer immediately. If C code modifies the |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1145 variable before we swap in, then that new value will clobber the |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1146 default value the next time we swap. */ |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1147 valcontents = XCONS (XSYMBOL (sym)->value)->car; |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1148 if (XTYPE (valcontents) == Lisp_Intfwd |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1149 || XTYPE (valcontents) == Lisp_Boolfwd |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1150 || XTYPE (valcontents) == Lisp_Objfwd) |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1151 swap_in_symval_forwarding (sym, XSYMBOL (sym)->value); |
0a0646ae381f
* data.c (Fmake_local_variable): If SYM forwards to a C variable,
Jim Blandy <jimb@redhat.com>
parents:
1263
diff
changeset
|
1152 |
298 | 1153 return sym; |
1154 } | |
1155 | |
1156 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable, | |
1157 1, 1, "vKill Local Variable: ", | |
1158 "Make VARIABLE no longer have a separate value in the current buffer.\n\ | |
1159 From now on the default value will apply in this buffer.") | |
1160 (sym) | |
1161 register Lisp_Object sym; | |
1162 { | |
1163 register Lisp_Object tem, valcontents; | |
1164 | |
1165 CHECK_SYMBOL (sym, 0); | |
1166 | |
1167 valcontents = XSYMBOL (sym)->value; | |
1168 | |
1169 if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) | |
1170 { | |
1171 register int idx = XUINT (valcontents); | |
1172 register int mask = *(int *) (idx + (char *) &buffer_local_flags); | |
1173 | |
1174 if (mask > 0) | |
1175 { | |
1176 *(Lisp_Object *)(idx + (char *) current_buffer) | |
1177 = *(Lisp_Object *)(idx + (char *) &buffer_defaults); | |
1178 current_buffer->local_var_flags &= ~mask; | |
1179 } | |
1180 return sym; | |
1181 } | |
1182 | |
1183 if (XTYPE (valcontents) != Lisp_Buffer_Local_Value && | |
1184 XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value) | |
1185 return sym; | |
1186 | |
1187 /* Get rid of this buffer's alist element, if any */ | |
1188 | |
1189 tem = Fassq (sym, current_buffer->local_var_alist); | |
490 | 1190 if (!NILP (tem)) |
298 | 1191 current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist); |
1192 | |
1193 /* Make sure symbol does not think it is set up for this buffer; | |
1194 force it to look once again for this buffer's value */ | |
1195 { | |
1196 Lisp_Object sv; | |
1197 sv = XSYMBOL (sym)->value; | |
1198 if (current_buffer == XBUFFER (XCONS (XCONS (sv)->cdr)->car)) | |
1199 XCONS (XCONS (sv)->cdr)->car = Qnil; | |
1200 } | |
1201 | |
1202 return sym; | |
1203 } | |
1204 | |
648 | 1205 /* Find the function at the end of a chain of symbol function indirections. */ |
1206 | |
1207 /* If OBJECT is a symbol, find the end of its function chain and | |
1208 return the value found there. If OBJECT is not a symbol, just | |
1209 return it. If there is a cycle in the function chain, signal a | |
1210 cyclic-function-indirection error. | |
1211 | |
1212 This is like Findirect_function, except that it doesn't signal an | |
1213 error if the chain ends up unbound. */ | |
1214 Lisp_Object | |
1648
27e9f99fe095
src/ * data.c (indirect_function): Delete unused argument ERROR.
Jim Blandy <jimb@redhat.com>
parents:
1508
diff
changeset
|
1215 indirect_function (object) |
648 | 1216 register Lisp_Object object; |
1217 { | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3529
diff
changeset
|
1218 Lisp_Object tortoise, hare; |
648 | 1219 |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3529
diff
changeset
|
1220 hare = tortoise = object; |
648 | 1221 |
1222 for (;;) | |
1223 { | |
1224 if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound)) | |
1225 break; | |
1226 hare = XSYMBOL (hare)->function; | |
1227 if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound)) | |
1228 break; | |
1229 hare = XSYMBOL (hare)->function; | |
1230 | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3529
diff
changeset
|
1231 tortoise = XSYMBOL (tortoise)->function; |
648 | 1232 |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3529
diff
changeset
|
1233 if (EQ (hare, tortoise)) |
648 | 1234 Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil)); |
1235 } | |
1236 | |
1237 return hare; | |
1238 } | |
1239 | |
1240 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0, | |
1241 "Return the function at the end of OBJECT's function chain.\n\ | |
1242 If OBJECT is a symbol, follow all function indirections and return the final\n\ | |
1243 function binding.\n\ | |
1244 If OBJECT is not a symbol, just return it.\n\ | |
1245 Signal a void-function error if the final symbol is unbound.\n\ | |
1246 Signal a cyclic-function-indirection error if there is a loop in the\n\ | |
1247 function chain of symbols.") | |
1248 (object) | |
1249 register Lisp_Object object; | |
1250 { | |
1251 Lisp_Object result; | |
1252 | |
1253 result = indirect_function (object); | |
1254 | |
1255 if (EQ (result, Qunbound)) | |
1256 return Fsignal (Qvoid_function, Fcons (object, Qnil)); | |
1257 return result; | |
1258 } | |
1259 | |
298 | 1260 /* Extract and set vector and string elements */ |
1261 | |
1262 DEFUN ("aref", Faref, Saref, 2, 2, 0, | |
1263 "Return the element of ARRAY at index INDEX.\n\ | |
1264 ARRAY may be a vector or a string, or a byte-code object. INDEX starts at 0.") | |
1265 (array, idx) | |
1266 register Lisp_Object array; | |
1267 Lisp_Object idx; | |
1268 { | |
1269 register int idxval; | |
1270 | |
1271 CHECK_NUMBER (idx, 1); | |
1272 idxval = XINT (idx); | |
1273 if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String | |
1274 && XTYPE (array) != Lisp_Compiled) | |
1275 array = wrong_type_argument (Qarrayp, array); | |
1276 if (idxval < 0 || idxval >= XVECTOR (array)->size) | |
1277 args_out_of_range (array, idx); | |
1278 if (XTYPE (array) == Lisp_String) | |
1279 { | |
1280 Lisp_Object val; | |
1281 XFASTINT (val) = (unsigned char) XSTRING (array)->data[idxval]; | |
1282 return val; | |
1283 } | |
1284 else | |
1285 return XVECTOR (array)->contents[idxval]; | |
1286 } | |
1287 | |
1288 DEFUN ("aset", Faset, Saset, 3, 3, 0, | |
1289 "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\ | |
1290 ARRAY may be a vector or a string. INDEX starts at 0.") | |
1291 (array, idx, newelt) | |
1292 register Lisp_Object array; | |
1293 Lisp_Object idx, newelt; | |
1294 { | |
1295 register int idxval; | |
1296 | |
1297 CHECK_NUMBER (idx, 1); | |
1298 idxval = XINT (idx); | |
1299 if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String) | |
1300 array = wrong_type_argument (Qarrayp, array); | |
1301 if (idxval < 0 || idxval >= XVECTOR (array)->size) | |
1302 args_out_of_range (array, idx); | |
1303 CHECK_IMPURE (array); | |
1304 | |
1305 if (XTYPE (array) == Lisp_Vector) | |
1306 XVECTOR (array)->contents[idxval] = newelt; | |
1307 else | |
1308 { | |
1309 CHECK_NUMBER (newelt, 2); | |
1310 XSTRING (array)->data[idxval] = XINT (newelt); | |
1311 } | |
1312 | |
1313 return newelt; | |
1314 } | |
1315 | |
1316 Lisp_Object | |
1317 Farray_length (array) | |
1318 register Lisp_Object array; | |
1319 { | |
1320 register Lisp_Object size; | |
1321 if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String | |
1322 && XTYPE (array) != Lisp_Compiled) | |
1323 array = wrong_type_argument (Qarrayp, array); | |
1324 XFASTINT (size) = XVECTOR (array)->size; | |
1325 return size; | |
1326 } | |
1327 | |
1328 /* Arithmetic functions */ | |
1329 | |
1330 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal }; | |
1331 | |
1332 Lisp_Object | |
1333 arithcompare (num1, num2, comparison) | |
1334 Lisp_Object num1, num2; | |
1335 enum comparison comparison; | |
1336 { | |
1337 double f1, f2; | |
1338 int floatp = 0; | |
1339 | |
1340 #ifdef LISP_FLOAT_TYPE | |
1341 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0); | |
1342 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0); | |
1343 | |
1344 if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float) | |
1345 { | |
1346 floatp = 1; | |
1347 f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1); | |
1348 f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2); | |
1349 } | |
1350 #else | |
1351 CHECK_NUMBER_COERCE_MARKER (num1, 0); | |
1352 CHECK_NUMBER_COERCE_MARKER (num2, 0); | |
1353 #endif /* LISP_FLOAT_TYPE */ | |
1354 | |
1355 switch (comparison) | |
1356 { | |
1357 case equal: | |
1358 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2)) | |
1359 return Qt; | |
1360 return Qnil; | |
1361 | |
1362 case notequal: | |
1363 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2)) | |
1364 return Qt; | |
1365 return Qnil; | |
1366 | |
1367 case less: | |
1368 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2)) | |
1369 return Qt; | |
1370 return Qnil; | |
1371 | |
1372 case less_or_equal: | |
1373 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2)) | |
1374 return Qt; | |
1375 return Qnil; | |
1376 | |
1377 case grtr: | |
1378 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2)) | |
1379 return Qt; | |
1380 return Qnil; | |
1381 | |
1382 case grtr_or_equal: | |
1383 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2)) | |
1384 return Qt; | |
1385 return Qnil; | |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1386 |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1387 default: |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1388 abort (); |
298 | 1389 } |
1390 } | |
1391 | |
1392 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0, | |
1393 "T if two args, both numbers or markers, are equal.") | |
1394 (num1, num2) | |
1395 register Lisp_Object num1, num2; | |
1396 { | |
1397 return arithcompare (num1, num2, equal); | |
1398 } | |
1399 | |
1400 DEFUN ("<", Flss, Slss, 2, 2, 0, | |
1401 "T if first arg is less than second arg. Both must be numbers or markers.") | |
1402 (num1, num2) | |
1403 register Lisp_Object num1, num2; | |
1404 { | |
1405 return arithcompare (num1, num2, less); | |
1406 } | |
1407 | |
1408 DEFUN (">", Fgtr, Sgtr, 2, 2, 0, | |
1409 "T if first arg is greater than second arg. Both must be numbers or markers.") | |
1410 (num1, num2) | |
1411 register Lisp_Object num1, num2; | |
1412 { | |
1413 return arithcompare (num1, num2, grtr); | |
1414 } | |
1415 | |
1416 DEFUN ("<=", Fleq, Sleq, 2, 2, 0, | |
1417 "T if first arg is less than or equal to second arg.\n\ | |
1418 Both must be numbers or markers.") | |
1419 (num1, num2) | |
1420 register Lisp_Object num1, num2; | |
1421 { | |
1422 return arithcompare (num1, num2, less_or_equal); | |
1423 } | |
1424 | |
1425 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0, | |
1426 "T if first arg is greater than or equal to second arg.\n\ | |
1427 Both must be numbers or markers.") | |
1428 (num1, num2) | |
1429 register Lisp_Object num1, num2; | |
1430 { | |
1431 return arithcompare (num1, num2, grtr_or_equal); | |
1432 } | |
1433 | |
1434 DEFUN ("/=", Fneq, Sneq, 2, 2, 0, | |
1435 "T if first arg is not equal to second arg. Both must be numbers or markers.") | |
1436 (num1, num2) | |
1437 register Lisp_Object num1, num2; | |
1438 { | |
1439 return arithcompare (num1, num2, notequal); | |
1440 } | |
1441 | |
1442 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.") | |
1443 (num) | |
1444 register Lisp_Object num; | |
1445 { | |
1446 #ifdef LISP_FLOAT_TYPE | |
1447 CHECK_NUMBER_OR_FLOAT (num, 0); | |
1448 | |
1449 if (XTYPE(num) == Lisp_Float) | |
1450 { | |
1451 if (XFLOAT(num)->data == 0.0) | |
1452 return Qt; | |
1453 return Qnil; | |
1454 } | |
1455 #else | |
1456 CHECK_NUMBER (num, 0); | |
1457 #endif /* LISP_FLOAT_TYPE */ | |
1458 | |
1459 if (!XINT (num)) | |
1460 return Qt; | |
1461 return Qnil; | |
1462 } | |
1463 | |
2515
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1464 /* Convert between 32-bit values and pairs of lispy 24-bit values. */ |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1465 |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1466 Lisp_Object |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1467 long_to_cons (i) |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1468 unsigned long i; |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1469 { |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1470 unsigned int top = i >> 16; |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1471 unsigned int bot = i & 0xFFFF; |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1472 if (top == 0) |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1473 return make_number (bot); |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1474 if (top == 0xFFFF) |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1475 return Fcons (make_number (-1), make_number (bot)); |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1476 return Fcons (make_number (top), make_number (bot)); |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1477 } |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1478 |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1479 unsigned long |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1480 cons_to_long (c) |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1481 Lisp_Object c; |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1482 { |
3675
f42eaf84478f
(cons_to_long): Declare top, bot as Lisp_Object.
Richard M. Stallman <rms@gnu.org>
parents:
3591
diff
changeset
|
1483 Lisp_Object top, bot; |
2515
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1484 if (INTEGERP (c)) |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1485 return XINT (c); |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1486 top = XCONS (c)->car; |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1487 bot = XCONS (c)->cdr; |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1488 if (CONSP (bot)) |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1489 bot = XCONS (bot)->car; |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1490 return ((XINT (top) << 16) | XINT (bot)); |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1491 } |
c0cdd6a80391
long_to_cons and cons_to_long are generally useful things; they're
Jim Blandy <jimb@redhat.com>
parents:
2429
diff
changeset
|
1492 |
2429
96b55f2f19cd
Rename int-to-string to number-to-string, since it can handle
Jim Blandy <jimb@redhat.com>
parents:
2092
diff
changeset
|
1493 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0, |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1494 "Convert NUM to a string by printing it in decimal.\n\ |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1495 Uses a minus sign if negative.\n\ |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1496 NUM may be an integer or a floating point number.") |
298 | 1497 (num) |
1498 Lisp_Object num; | |
1499 { | |
1500 char buffer[20]; | |
1501 | |
1502 #ifndef LISP_FLOAT_TYPE | |
1503 CHECK_NUMBER (num, 0); | |
1504 #else | |
1505 CHECK_NUMBER_OR_FLOAT (num, 0); | |
1506 | |
1507 if (XTYPE(num) == Lisp_Float) | |
1508 { | |
1509 char pigbuf[350]; /* see comments in float_to_string */ | |
1510 | |
1511 float_to_string (pigbuf, XFLOAT(num)->data); | |
1512 return build_string (pigbuf); | |
1513 } | |
1514 #endif /* LISP_FLOAT_TYPE */ | |
1515 | |
1516 sprintf (buffer, "%d", XINT (num)); | |
1517 return build_string (buffer); | |
1518 } | |
1519 | |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1520 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0, |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1521 "Convert STRING to a number by parsing it as a decimal number.\n\ |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1522 This parses both integers and floating point numbers.") |
298 | 1523 (str) |
1524 register Lisp_Object str; | |
1525 { | |
1987
cd893024d6b9
* data.c (Fstring_to_number): Declare p to be an unsigned char, to
Jim Blandy <jimb@redhat.com>
parents:
1914
diff
changeset
|
1526 unsigned char *p; |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1527 |
298 | 1528 CHECK_STRING (str, 0); |
1529 | |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1530 p = XSTRING (str)->data; |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1531 |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1532 /* Skip any whitespace at the front of the number. Some versions of |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1533 atoi do this anyway, so we might as well make Emacs lisp consistent. */ |
1987
cd893024d6b9
* data.c (Fstring_to_number): Declare p to be an unsigned char, to
Jim Blandy <jimb@redhat.com>
parents:
1914
diff
changeset
|
1534 while (*p == ' ' || *p == '\t') |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1535 p++; |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1536 |
298 | 1537 #ifdef LISP_FLOAT_TYPE |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1538 if (isfloat_string (p)) |
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1539 return make_float (atof (p)); |
298 | 1540 #endif /* LISP_FLOAT_TYPE */ |
1541 | |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
1542 return make_number (atoi (p)); |
298 | 1543 } |
1544 | |
1545 enum arithop | |
1546 { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin }; | |
1547 | |
1508
768d4c10c2bf
* data.c (Fset): See if current_alist_element points to itself
Jim Blandy <jimb@redhat.com>
parents:
1293
diff
changeset
|
1548 extern Lisp_Object float_arith_driver (); |
768d4c10c2bf
* data.c (Fset): See if current_alist_element points to itself
Jim Blandy <jimb@redhat.com>
parents:
1293
diff
changeset
|
1549 |
298 | 1550 Lisp_Object |
3338
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1551 arith_driver (code, nargs, args) |
298 | 1552 enum arithop code; |
1553 int nargs; | |
1554 register Lisp_Object *args; | |
1555 { | |
1556 register Lisp_Object val; | |
1557 register int argnum; | |
1558 register int accum; | |
1559 register int next; | |
1560 | |
1561 #ifdef SWITCH_ENUM_BUG | |
1562 switch ((int) code) | |
1563 #else | |
1564 switch (code) | |
1565 #endif | |
1566 { | |
1567 case Alogior: | |
1568 case Alogxor: | |
1569 case Aadd: | |
1570 case Asub: | |
1571 accum = 0; break; | |
1572 case Amult: | |
1573 accum = 1; break; | |
1574 case Alogand: | |
1575 accum = -1; break; | |
1576 } | |
1577 | |
1578 for (argnum = 0; argnum < nargs; argnum++) | |
1579 { | |
1580 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ | |
1581 #ifdef LISP_FLOAT_TYPE | |
1582 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum); | |
1583 | |
1584 if (XTYPE (val) == Lisp_Float) /* time to do serious math */ | |
1585 return (float_arith_driver ((double) accum, argnum, code, | |
1586 nargs, args)); | |
1587 #else | |
1588 CHECK_NUMBER_COERCE_MARKER (val, argnum); | |
1589 #endif /* LISP_FLOAT_TYPE */ | |
1590 args[argnum] = val; /* runs into a compiler bug. */ | |
1591 next = XINT (args[argnum]); | |
1592 #ifdef SWITCH_ENUM_BUG | |
1593 switch ((int) code) | |
1594 #else | |
1595 switch (code) | |
1596 #endif | |
1597 { | |
1598 case Aadd: accum += next; break; | |
1599 case Asub: | |
1600 if (!argnum && nargs != 1) | |
1601 next = - next; | |
1602 accum -= next; | |
1603 break; | |
1604 case Amult: accum *= next; break; | |
1605 case Adiv: | |
1606 if (!argnum) accum = next; | |
3338
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1607 else |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1608 { |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1609 if (next == 0) |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1610 Fsignal (Qarith_error, Qnil); |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1611 accum /= next; |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1612 } |
298 | 1613 break; |
1614 case Alogand: accum &= next; break; | |
1615 case Alogior: accum |= next; break; | |
1616 case Alogxor: accum ^= next; break; | |
1617 case Amax: if (!argnum || next > accum) accum = next; break; | |
1618 case Amin: if (!argnum || next < accum) accum = next; break; | |
1619 } | |
1620 } | |
1621 | |
1622 XSET (val, Lisp_Int, accum); | |
1623 return val; | |
1624 } | |
1625 | |
1626 #ifdef LISP_FLOAT_TYPE | |
1627 Lisp_Object | |
1628 float_arith_driver (accum, argnum, code, nargs, args) | |
1629 double accum; | |
1630 register int argnum; | |
1631 enum arithop code; | |
1632 int nargs; | |
1633 register Lisp_Object *args; | |
1634 { | |
1635 register Lisp_Object val; | |
1636 double next; | |
1637 | |
1638 for (; argnum < nargs; argnum++) | |
1639 { | |
1640 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ | |
1641 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum); | |
1642 | |
1643 if (XTYPE (val) == Lisp_Float) | |
1644 { | |
1645 next = XFLOAT (val)->data; | |
1646 } | |
1647 else | |
1648 { | |
1649 args[argnum] = val; /* runs into a compiler bug. */ | |
1650 next = XINT (args[argnum]); | |
1651 } | |
1652 #ifdef SWITCH_ENUM_BUG | |
1653 switch ((int) code) | |
1654 #else | |
1655 switch (code) | |
1656 #endif | |
1657 { | |
1658 case Aadd: | |
1659 accum += next; | |
1660 break; | |
1661 case Asub: | |
1662 if (!argnum && nargs != 1) | |
1663 next = - next; | |
1664 accum -= next; | |
1665 break; | |
1666 case Amult: | |
1667 accum *= next; | |
1668 break; | |
1669 case Adiv: | |
1670 if (!argnum) | |
1671 accum = next; | |
1672 else | |
3338
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1673 { |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1674 if (next == 0) |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1675 Fsignal (Qarith_error, Qnil); |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1676 accum /= next; |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1677 } |
298 | 1678 break; |
1679 case Alogand: | |
1680 case Alogior: | |
1681 case Alogxor: | |
1682 return wrong_type_argument (Qinteger_or_marker_p, val); | |
1683 case Amax: | |
1684 if (!argnum || next > accum) | |
1685 accum = next; | |
1686 break; | |
1687 case Amin: | |
1688 if (!argnum || next < accum) | |
1689 accum = next; | |
1690 break; | |
1691 } | |
1692 } | |
1693 | |
1694 return make_float (accum); | |
1695 } | |
1696 #endif /* LISP_FLOAT_TYPE */ | |
1697 | |
1698 DEFUN ("+", Fplus, Splus, 0, MANY, 0, | |
1699 "Return sum of any number of arguments, which are numbers or markers.") | |
1700 (nargs, args) | |
1701 int nargs; | |
1702 Lisp_Object *args; | |
1703 { | |
1704 return arith_driver (Aadd, nargs, args); | |
1705 } | |
1706 | |
1707 DEFUN ("-", Fminus, Sminus, 0, MANY, 0, | |
1708 "Negate number or subtract numbers or markers.\n\ | |
1709 With one arg, negates it. With more than one arg,\n\ | |
1710 subtracts all but the first from the first.") | |
1711 (nargs, args) | |
1712 int nargs; | |
1713 Lisp_Object *args; | |
1714 { | |
1715 return arith_driver (Asub, nargs, args); | |
1716 } | |
1717 | |
1718 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, | |
1719 "Returns product of any number of arguments, which are numbers or markers.") | |
1720 (nargs, args) | |
1721 int nargs; | |
1722 Lisp_Object *args; | |
1723 { | |
1724 return arith_driver (Amult, nargs, args); | |
1725 } | |
1726 | |
1727 DEFUN ("/", Fquo, Squo, 2, MANY, 0, | |
1728 "Returns first argument divided by all the remaining arguments.\n\ | |
1729 The arguments must be numbers or markers.") | |
1730 (nargs, args) | |
1731 int nargs; | |
1732 Lisp_Object *args; | |
1733 { | |
1734 return arith_driver (Adiv, nargs, args); | |
1735 } | |
1736 | |
1737 DEFUN ("%", Frem, Srem, 2, 2, 0, | |
1738 "Returns remainder of first arg divided by second.\n\ | |
1739 Both must be numbers or markers.") | |
1740 (num1, num2) | |
1741 register Lisp_Object num1, num2; | |
1742 { | |
1743 Lisp_Object val; | |
1744 | |
1745 #ifdef LISP_FLOAT_TYPE | |
1746 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0); | |
1747 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0); | |
1748 | |
1749 if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float) | |
1750 { | |
1751 double f1, f2; | |
1752 | |
1753 f1 = XTYPE (num1) == Lisp_Float ? XFLOAT (num1)->data : XINT (num1); | |
1754 f2 = XTYPE (num2) == Lisp_Float ? XFLOAT (num2)->data : XINT (num2); | |
3338
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1755 if (f2 == 0) |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1756 Fsignal (Qarith_error, Qnil); |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1757 |
1253
7afcf7be0d30
* data.c (Frem): Use the `fmod' function under SunOS, Ultrix, and
Jim Blandy <jimb@redhat.com>
parents:
1002
diff
changeset
|
1758 #if defined (USG) || defined (sun) || defined (ultrix) || defined (hpux) |
1002
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
1759 f1 = fmod (f1, f2); |
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
1760 #else |
733 | 1761 f1 = drem (f1, f2); |
1002
65f15f1961d8
* data.c [USG] (Frem): Call fmod, rather than drem. Rah.
Jim Blandy <jimb@redhat.com>
parents:
733
diff
changeset
|
1762 #endif |
3378
cb9eb3e46e2c
(Frem): Fix result sign properly.
Richard M. Stallman <rms@gnu.org>
parents:
3338
diff
changeset
|
1763 /* If the "remainder" comes out with the wrong sign, fix it. */ |
cb9eb3e46e2c
(Frem): Fix result sign properly.
Richard M. Stallman <rms@gnu.org>
parents:
3338
diff
changeset
|
1764 if ((f1 < 0) != (f2 < 0)) |
733 | 1765 f1 += f2; |
1766 return (make_float (f1)); | |
298 | 1767 } |
1768 #else /* not LISP_FLOAT_TYPE */ | |
1769 CHECK_NUMBER_COERCE_MARKER (num1, 0); | |
1770 CHECK_NUMBER_COERCE_MARKER (num2, 1); | |
1771 #endif /* not LISP_FLOAT_TYPE */ | |
1772 | |
3338
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1773 if (XFASTINT (num2) == 0) |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1774 Fsignal (Qarith_error, Qnil); |
30b946dd8c66
(float_arith_driver): Detect division by zero in advance.
Richard M. Stallman <rms@gnu.org>
parents:
2961
diff
changeset
|
1775 |
298 | 1776 XSET (val, Lisp_Int, XINT (num1) % XINT (num2)); |
1777 return val; | |
1778 } | |
1779 | |
1780 DEFUN ("max", Fmax, Smax, 1, MANY, 0, | |
1781 "Return largest of all the arguments (which must be numbers or markers).\n\ | |
1782 The value is always a number; markers are converted to numbers.") | |
1783 (nargs, args) | |
1784 int nargs; | |
1785 Lisp_Object *args; | |
1786 { | |
1787 return arith_driver (Amax, nargs, args); | |
1788 } | |
1789 | |
1790 DEFUN ("min", Fmin, Smin, 1, MANY, 0, | |
1791 "Return smallest of all the arguments (which must be numbers or markers).\n\ | |
1792 The value is always a number; markers are converted to numbers.") | |
1793 (nargs, args) | |
1794 int nargs; | |
1795 Lisp_Object *args; | |
1796 { | |
1797 return arith_driver (Amin, nargs, args); | |
1798 } | |
1799 | |
1800 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0, | |
1801 "Return bitwise-and of all the arguments.\n\ | |
1802 Arguments may be integers, or markers converted to integers.") | |
1803 (nargs, args) | |
1804 int nargs; | |
1805 Lisp_Object *args; | |
1806 { | |
1807 return arith_driver (Alogand, nargs, args); | |
1808 } | |
1809 | |
1810 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0, | |
1811 "Return bitwise-or of all the arguments.\n\ | |
1812 Arguments may be integers, or markers converted to integers.") | |
1813 (nargs, args) | |
1814 int nargs; | |
1815 Lisp_Object *args; | |
1816 { | |
1817 return arith_driver (Alogior, nargs, args); | |
1818 } | |
1819 | |
1820 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0, | |
1821 "Return bitwise-exclusive-or of all the arguments.\n\ | |
1822 Arguments may be integers, or markers converted to integers.") | |
1823 (nargs, args) | |
1824 int nargs; | |
1825 Lisp_Object *args; | |
1826 { | |
1827 return arith_driver (Alogxor, nargs, args); | |
1828 } | |
1829 | |
1830 DEFUN ("ash", Fash, Sash, 2, 2, 0, | |
1831 "Return VALUE with its bits shifted left by COUNT.\n\ | |
1832 If COUNT is negative, shifting is actually to the right.\n\ | |
1833 In this case, the sign bit is duplicated.") | |
1834 (num1, num2) | |
1835 register Lisp_Object num1, num2; | |
1836 { | |
1837 register Lisp_Object val; | |
1838 | |
1839 CHECK_NUMBER (num1, 0); | |
1840 CHECK_NUMBER (num2, 1); | |
1841 | |
1842 if (XINT (num2) > 0) | |
1843 XSET (val, Lisp_Int, XINT (num1) << XFASTINT (num2)); | |
1844 else | |
1845 XSET (val, Lisp_Int, XINT (num1) >> -XINT (num2)); | |
1846 return val; | |
1847 } | |
1848 | |
1849 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0, | |
1850 "Return VALUE with its bits shifted left by COUNT.\n\ | |
1851 If COUNT is negative, shifting is actually to the right.\n\ | |
1852 In this case, zeros are shifted in on the left.") | |
1853 (num1, num2) | |
1854 register Lisp_Object num1, num2; | |
1855 { | |
1856 register Lisp_Object val; | |
1857 | |
1858 CHECK_NUMBER (num1, 0); | |
1859 CHECK_NUMBER (num2, 1); | |
1860 | |
1861 if (XINT (num2) > 0) | |
1862 XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) << XFASTINT (num2)); | |
1863 else | |
1864 XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) >> -XINT (num2)); | |
1865 return val; | |
1866 } | |
1867 | |
1868 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, | |
1869 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\ | |
1870 Markers are converted to integers.") | |
1871 (num) | |
1872 register Lisp_Object num; | |
1873 { | |
1874 #ifdef LISP_FLOAT_TYPE | |
1875 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0); | |
1876 | |
1877 if (XTYPE (num) == Lisp_Float) | |
1878 return (make_float (1.0 + XFLOAT (num)->data)); | |
1879 #else | |
1880 CHECK_NUMBER_COERCE_MARKER (num, 0); | |
1881 #endif /* LISP_FLOAT_TYPE */ | |
1882 | |
1883 XSETINT (num, XFASTINT (num) + 1); | |
1884 return num; | |
1885 } | |
1886 | |
1887 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, | |
1888 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\ | |
1889 Markers are converted to integers.") | |
1890 (num) | |
1891 register Lisp_Object num; | |
1892 { | |
1893 #ifdef LISP_FLOAT_TYPE | |
1894 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0); | |
1895 | |
1896 if (XTYPE (num) == Lisp_Float) | |
1897 return (make_float (-1.0 + XFLOAT (num)->data)); | |
1898 #else | |
1899 CHECK_NUMBER_COERCE_MARKER (num, 0); | |
1900 #endif /* LISP_FLOAT_TYPE */ | |
1901 | |
1902 XSETINT (num, XFASTINT (num) - 1); | |
1903 return num; | |
1904 } | |
1905 | |
1906 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, | |
1907 "Return the bitwise complement of ARG. ARG must be an integer.") | |
1908 (num) | |
1909 register Lisp_Object num; | |
1910 { | |
1911 CHECK_NUMBER (num, 0); | |
1912 XSETINT (num, ~XFASTINT (num)); | |
1913 return num; | |
1914 } | |
1915 | |
1916 void | |
1917 syms_of_data () | |
1918 { | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1919 Lisp_Object error_tail, arith_tail; |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1920 |
298 | 1921 Qquote = intern ("quote"); |
1922 Qlambda = intern ("lambda"); | |
1923 Qsubr = intern ("subr"); | |
1924 Qerror_conditions = intern ("error-conditions"); | |
1925 Qerror_message = intern ("error-message"); | |
1926 Qtop_level = intern ("top-level"); | |
1927 | |
1928 Qerror = intern ("error"); | |
1929 Qquit = intern ("quit"); | |
1930 Qwrong_type_argument = intern ("wrong-type-argument"); | |
1931 Qargs_out_of_range = intern ("args-out-of-range"); | |
1932 Qvoid_function = intern ("void-function"); | |
648 | 1933 Qcyclic_function_indirection = intern ("cyclic-function-indirection"); |
298 | 1934 Qvoid_variable = intern ("void-variable"); |
1935 Qsetting_constant = intern ("setting-constant"); | |
1936 Qinvalid_read_syntax = intern ("invalid-read-syntax"); | |
1937 | |
1938 Qinvalid_function = intern ("invalid-function"); | |
1939 Qwrong_number_of_arguments = intern ("wrong-number-of-arguments"); | |
1940 Qno_catch = intern ("no-catch"); | |
1941 Qend_of_file = intern ("end-of-file"); | |
1942 Qarith_error = intern ("arith-error"); | |
1943 Qbeginning_of_buffer = intern ("beginning-of-buffer"); | |
1944 Qend_of_buffer = intern ("end-of-buffer"); | |
1945 Qbuffer_read_only = intern ("buffer-read-only"); | |
4036 | 1946 Qmark_inactive = intern ("mark-inactive"); |
298 | 1947 |
1948 Qlistp = intern ("listp"); | |
1949 Qconsp = intern ("consp"); | |
1950 Qsymbolp = intern ("symbolp"); | |
1951 Qintegerp = intern ("integerp"); | |
1952 Qnatnump = intern ("natnump"); | |
1953 Qstringp = intern ("stringp"); | |
1954 Qarrayp = intern ("arrayp"); | |
1955 Qsequencep = intern ("sequencep"); | |
1956 Qbufferp = intern ("bufferp"); | |
1957 Qvectorp = intern ("vectorp"); | |
1958 Qchar_or_string_p = intern ("char-or-string-p"); | |
1959 Qmarkerp = intern ("markerp"); | |
1293 | 1960 Qbuffer_or_string_p = intern ("buffer-or-string-p"); |
298 | 1961 Qinteger_or_marker_p = intern ("integer-or-marker-p"); |
1962 Qboundp = intern ("boundp"); | |
1963 Qfboundp = intern ("fboundp"); | |
1964 | |
1965 #ifdef LISP_FLOAT_TYPE | |
1966 Qfloatp = intern ("floatp"); | |
1967 Qnumberp = intern ("numberp"); | |
1968 Qnumber_or_marker_p = intern ("number-or-marker-p"); | |
1969 #endif /* LISP_FLOAT_TYPE */ | |
1970 | |
1971 Qcdr = intern ("cdr"); | |
1972 | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1973 error_tail = Fcons (Qerror, Qnil); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1974 |
298 | 1975 /* ERROR is used as a signaler for random errors for which nothing else is right */ |
1976 | |
1977 Fput (Qerror, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1978 error_tail); |
298 | 1979 Fput (Qerror, Qerror_message, |
1980 build_string ("error")); | |
1981 | |
1982 Fput (Qquit, Qerror_conditions, | |
1983 Fcons (Qquit, Qnil)); | |
1984 Fput (Qquit, Qerror_message, | |
1985 build_string ("Quit")); | |
1986 | |
1987 Fput (Qwrong_type_argument, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1988 Fcons (Qwrong_type_argument, error_tail)); |
298 | 1989 Fput (Qwrong_type_argument, Qerror_message, |
1990 build_string ("Wrong type argument")); | |
1991 | |
1992 Fput (Qargs_out_of_range, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1993 Fcons (Qargs_out_of_range, error_tail)); |
298 | 1994 Fput (Qargs_out_of_range, Qerror_message, |
1995 build_string ("Args out of range")); | |
1996 | |
1997 Fput (Qvoid_function, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
1998 Fcons (Qvoid_function, error_tail)); |
298 | 1999 Fput (Qvoid_function, Qerror_message, |
2000 build_string ("Symbol's function definition is void")); | |
2001 | |
648 | 2002 Fput (Qcyclic_function_indirection, Qerror_conditions, |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2003 Fcons (Qcyclic_function_indirection, error_tail)); |
648 | 2004 Fput (Qcyclic_function_indirection, Qerror_message, |
2005 build_string ("Symbol's chain of function indirections contains a loop")); | |
2006 | |
298 | 2007 Fput (Qvoid_variable, Qerror_conditions, |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2008 Fcons (Qvoid_variable, error_tail)); |
298 | 2009 Fput (Qvoid_variable, Qerror_message, |
2010 build_string ("Symbol's value as variable is void")); | |
2011 | |
2012 Fput (Qsetting_constant, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2013 Fcons (Qsetting_constant, error_tail)); |
298 | 2014 Fput (Qsetting_constant, Qerror_message, |
2015 build_string ("Attempt to set a constant symbol")); | |
2016 | |
2017 Fput (Qinvalid_read_syntax, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2018 Fcons (Qinvalid_read_syntax, error_tail)); |
298 | 2019 Fput (Qinvalid_read_syntax, Qerror_message, |
2020 build_string ("Invalid read syntax")); | |
2021 | |
2022 Fput (Qinvalid_function, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2023 Fcons (Qinvalid_function, error_tail)); |
298 | 2024 Fput (Qinvalid_function, Qerror_message, |
2025 build_string ("Invalid function")); | |
2026 | |
2027 Fput (Qwrong_number_of_arguments, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2028 Fcons (Qwrong_number_of_arguments, error_tail)); |
298 | 2029 Fput (Qwrong_number_of_arguments, Qerror_message, |
2030 build_string ("Wrong number of arguments")); | |
2031 | |
2032 Fput (Qno_catch, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2033 Fcons (Qno_catch, error_tail)); |
298 | 2034 Fput (Qno_catch, Qerror_message, |
2035 build_string ("No catch for tag")); | |
2036 | |
2037 Fput (Qend_of_file, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2038 Fcons (Qend_of_file, error_tail)); |
298 | 2039 Fput (Qend_of_file, Qerror_message, |
2040 build_string ("End of file during parsing")); | |
2041 | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2042 arith_tail = Fcons (Qarith_error, error_tail); |
298 | 2043 Fput (Qarith_error, Qerror_conditions, |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2044 arith_tail); |
298 | 2045 Fput (Qarith_error, Qerror_message, |
2046 build_string ("Arithmetic error")); | |
2047 | |
2048 Fput (Qbeginning_of_buffer, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2049 Fcons (Qbeginning_of_buffer, error_tail)); |
298 | 2050 Fput (Qbeginning_of_buffer, Qerror_message, |
2051 build_string ("Beginning of buffer")); | |
2052 | |
2053 Fput (Qend_of_buffer, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2054 Fcons (Qend_of_buffer, error_tail)); |
298 | 2055 Fput (Qend_of_buffer, Qerror_message, |
2056 build_string ("End of buffer")); | |
2057 | |
2058 Fput (Qbuffer_read_only, Qerror_conditions, | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2059 Fcons (Qbuffer_read_only, error_tail)); |
298 | 2060 Fput (Qbuffer_read_only, Qerror_message, |
2061 build_string ("Buffer is read-only")); | |
2062 | |
2092
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2063 #ifdef LISP_FLOAT_TYPE |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2064 Qrange_error = intern ("range-error"); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2065 Qdomain_error = intern ("domain-error"); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2066 Qsingularity_error = intern ("singularity-error"); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2067 Qoverflow_error = intern ("overflow-error"); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2068 Qunderflow_error = intern ("underflow-error"); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2069 |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2070 Fput (Qdomain_error, Qerror_conditions, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2071 Fcons (Qdomain_error, arith_tail)); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2072 Fput (Qdomain_error, Qerror_message, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2073 build_string ("Arithmetic domain error")); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2074 |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2075 Fput (Qrange_error, Qerror_conditions, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2076 Fcons (Qrange_error, arith_tail)); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2077 Fput (Qrange_error, Qerror_message, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2078 build_string ("Arithmetic range error")); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2079 |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2080 Fput (Qsingularity_error, Qerror_conditions, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2081 Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail))); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2082 Fput (Qsingularity_error, Qerror_message, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2083 build_string ("Arithmetic singularity error")); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2084 |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2085 Fput (Qoverflow_error, Qerror_conditions, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2086 Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail))); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2087 Fput (Qoverflow_error, Qerror_message, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2088 build_string ("Arithmetic overflow error")); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2089 |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2090 Fput (Qunderflow_error, Qerror_conditions, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2091 Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail))); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2092 Fput (Qunderflow_error, Qerror_message, |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2093 build_string ("Arithmetic underflow error")); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2094 |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2095 staticpro (&Qrange_error); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2096 staticpro (&Qdomain_error); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2097 staticpro (&Qsingularity_error); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2098 staticpro (&Qoverflow_error); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2099 staticpro (&Qunderflow_error); |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2100 #endif /* LISP_FLOAT_TYPE */ |
7497fce1e426
(syms_of_data) [LISP_FLOAT_TYPE]: Define new error conditions:
Richard M. Stallman <rms@gnu.org>
parents:
1987
diff
changeset
|
2101 |
298 | 2102 staticpro (&Qnil); |
2103 staticpro (&Qt); | |
2104 staticpro (&Qquote); | |
2105 staticpro (&Qlambda); | |
2106 staticpro (&Qsubr); | |
2107 staticpro (&Qunbound); | |
2108 staticpro (&Qerror_conditions); | |
2109 staticpro (&Qerror_message); | |
2110 staticpro (&Qtop_level); | |
2111 | |
2112 staticpro (&Qerror); | |
2113 staticpro (&Qquit); | |
2114 staticpro (&Qwrong_type_argument); | |
2115 staticpro (&Qargs_out_of_range); | |
2116 staticpro (&Qvoid_function); | |
648 | 2117 staticpro (&Qcyclic_function_indirection); |
298 | 2118 staticpro (&Qvoid_variable); |
2119 staticpro (&Qsetting_constant); | |
2120 staticpro (&Qinvalid_read_syntax); | |
2121 staticpro (&Qwrong_number_of_arguments); | |
2122 staticpro (&Qinvalid_function); | |
2123 staticpro (&Qno_catch); | |
2124 staticpro (&Qend_of_file); | |
2125 staticpro (&Qarith_error); | |
2126 staticpro (&Qbeginning_of_buffer); | |
2127 staticpro (&Qend_of_buffer); | |
2128 staticpro (&Qbuffer_read_only); | |
4037
aecb99c65ab0
(syms_of_data): Staticpro Qmark_inactive.
Roland McGrath <roland@gnu.org>
parents:
4036
diff
changeset
|
2129 staticpro (&Qmark_inactive); |
298 | 2130 |
2131 staticpro (&Qlistp); | |
2132 staticpro (&Qconsp); | |
2133 staticpro (&Qsymbolp); | |
2134 staticpro (&Qintegerp); | |
2135 staticpro (&Qnatnump); | |
2136 staticpro (&Qstringp); | |
2137 staticpro (&Qarrayp); | |
2138 staticpro (&Qsequencep); | |
2139 staticpro (&Qbufferp); | |
2140 staticpro (&Qvectorp); | |
2141 staticpro (&Qchar_or_string_p); | |
2142 staticpro (&Qmarkerp); | |
1293 | 2143 staticpro (&Qbuffer_or_string_p); |
298 | 2144 staticpro (&Qinteger_or_marker_p); |
2145 #ifdef LISP_FLOAT_TYPE | |
2146 staticpro (&Qfloatp); | |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
2147 staticpro (&Qnumberp); |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
2148 staticpro (&Qnumber_or_marker_p); |
298 | 2149 #endif /* LISP_FLOAT_TYPE */ |
2150 | |
2151 staticpro (&Qboundp); | |
2152 staticpro (&Qfboundp); | |
2153 staticpro (&Qcdr); | |
2154 | |
2155 defsubr (&Seq); | |
2156 defsubr (&Snull); | |
2157 defsubr (&Slistp); | |
2158 defsubr (&Snlistp); | |
2159 defsubr (&Sconsp); | |
2160 defsubr (&Satom); | |
2161 defsubr (&Sintegerp); | |
695
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
2162 defsubr (&Sinteger_or_marker_p); |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
2163 defsubr (&Snumberp); |
e3fac20d3015
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
648
diff
changeset
|
2164 defsubr (&Snumber_or_marker_p); |
298 | 2165 #ifdef LISP_FLOAT_TYPE |
2166 defsubr (&Sfloatp); | |
2167 #endif /* LISP_FLOAT_TYPE */ | |
2168 defsubr (&Snatnump); | |
2169 defsubr (&Ssymbolp); | |
2170 defsubr (&Sstringp); | |
2171 defsubr (&Svectorp); | |
2172 defsubr (&Sarrayp); | |
2173 defsubr (&Ssequencep); | |
2174 defsubr (&Sbufferp); | |
2175 defsubr (&Smarkerp); | |
2176 defsubr (&Ssubrp); | |
1821
04fb1d3d6992
JimB's changes since January 18th
Jim Blandy <jimb@redhat.com>
parents:
1648
diff
changeset
|
2177 defsubr (&Sbyte_code_function_p); |
298 | 2178 defsubr (&Schar_or_string_p); |
2179 defsubr (&Scar); | |
2180 defsubr (&Scdr); | |
2181 defsubr (&Scar_safe); | |
2182 defsubr (&Scdr_safe); | |
2183 defsubr (&Ssetcar); | |
2184 defsubr (&Ssetcdr); | |
2185 defsubr (&Ssymbol_function); | |
648 | 2186 defsubr (&Sindirect_function); |
298 | 2187 defsubr (&Ssymbol_plist); |
2188 defsubr (&Ssymbol_name); | |
2189 defsubr (&Smakunbound); | |
2190 defsubr (&Sfmakunbound); | |
2191 defsubr (&Sboundp); | |
2192 defsubr (&Sfboundp); | |
2193 defsubr (&Sfset); | |
2565
c1a1557bffde
(Fdefine_function): Changed name back to Fdefalias, so we get things
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
2548
diff
changeset
|
2194 defsubr (&Sdefalias); |
2606
6bf6499fe4db
(Fdefine_function): New function (same code as Fdefalias).
Richard M. Stallman <rms@gnu.org>
parents:
2565
diff
changeset
|
2195 defsubr (&Sdefine_function); |
298 | 2196 defsubr (&Ssetplist); |
2197 defsubr (&Ssymbol_value); | |
2198 defsubr (&Sset); | |
2199 defsubr (&Sdefault_boundp); | |
2200 defsubr (&Sdefault_value); | |
2201 defsubr (&Sset_default); | |
2202 defsubr (&Ssetq_default); | |
2203 defsubr (&Smake_variable_buffer_local); | |
2204 defsubr (&Smake_local_variable); | |
2205 defsubr (&Skill_local_variable); | |
2206 defsubr (&Saref); | |
2207 defsubr (&Saset); | |
2429
96b55f2f19cd
Rename int-to-string to number-to-string, since it can handle
Jim Blandy <jimb@redhat.com>
parents:
2092
diff
changeset
|
2208 defsubr (&Snumber_to_string); |
1914
60965a5c325f
* data.c (Fstring_to_number): Skip initial spaces, to make Emacs
Jim Blandy <jimb@redhat.com>
parents:
1821
diff
changeset
|
2209 defsubr (&Sstring_to_number); |
298 | 2210 defsubr (&Seqlsign); |
2211 defsubr (&Slss); | |
2212 defsubr (&Sgtr); | |
2213 defsubr (&Sleq); | |
2214 defsubr (&Sgeq); | |
2215 defsubr (&Sneq); | |
2216 defsubr (&Szerop); | |
2217 defsubr (&Splus); | |
2218 defsubr (&Sminus); | |
2219 defsubr (&Stimes); | |
2220 defsubr (&Squo); | |
2221 defsubr (&Srem); | |
2222 defsubr (&Smax); | |
2223 defsubr (&Smin); | |
2224 defsubr (&Slogand); | |
2225 defsubr (&Slogior); | |
2226 defsubr (&Slogxor); | |
2227 defsubr (&Slsh); | |
2228 defsubr (&Sash); | |
2229 defsubr (&Sadd1); | |
2230 defsubr (&Ssub1); | |
2231 defsubr (&Slognot); | |
2232 } | |
2233 | |
490 | 2234 SIGTYPE |
298 | 2235 arith_error (signo) |
2236 int signo; | |
2237 { | |
2238 #ifdef USG | |
2239 /* USG systems forget handlers when they are used; | |
2240 must reestablish each time */ | |
2241 signal (signo, arith_error); | |
2242 #endif /* USG */ | |
2243 #ifdef VMS | |
2244 /* VMS systems are like USG. */ | |
2245 signal (signo, arith_error); | |
2246 #endif /* VMS */ | |
2247 #ifdef BSD4_1 | |
2248 sigrelse (SIGFPE); | |
2249 #else /* not BSD4_1 */ | |
638 | 2250 sigsetmask (SIGEMPTYMASK); |
298 | 2251 #endif /* not BSD4_1 */ |
2252 | |
2253 Fsignal (Qarith_error, Qnil); | |
2254 } | |
2255 | |
2256 init_data () | |
2257 { | |
2258 /* Don't do this if just dumping out. | |
2259 We don't want to call `signal' in this case | |
2260 so that we don't have trouble with dumping | |
2261 signal-delivering routines in an inconsistent state. */ | |
2262 #ifndef CANNOT_DUMP | |
2263 if (!initialized) | |
2264 return; | |
2265 #endif /* CANNOT_DUMP */ | |
2266 signal (SIGFPE, arith_error); | |
591 | 2267 |
298 | 2268 #ifdef uts |
2269 signal (SIGEMT, arith_error); | |
2270 #endif /* uts */ | |
2271 } |