Mercurial > hg > xemacs-beta
annotate src/number-mp.c @ 5084:6afe991b8135
Add a PARSE_KEYWORDS macro, use it in #'make-hash-table.
lisp/ChangeLog addition:
2010-03-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el (cl-parsing-keywords):
* cl-macs.el (cl-do-arglist):
Use the new invalid-keyword-argument error here.
src/ChangeLog addition:
2010-03-01 Aidan Kehoe <kehoea@parhasard.net>
* lisp.h (PARSE_KEYWORDS): New macro, for parsing keyword
arguments from C subrs.
* elhash.c (Fmake_hash_table): Use it.
* general-slots.h (Q_allow_other_keys): Add this symbol.
* eval.c (non_nil_allow_other_keys_p):
(invalid_keyword_argument):
New functions, called from the keyword argument parsing code.
* data.c (init_errors_once_early):
Add the new invalid-keyword-argument error here.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Mon, 01 Mar 2010 21:05:33 +0000 |
parents | 16112448d484 |
children | ba07c880114a |
rev | line source |
---|---|
1983 | 1 /* Numeric types for XEmacs using the MP library. |
2 Copyright (C) 2004 Jerry James. | |
3 | |
4 This file is part of XEmacs. | |
5 | |
6 XEmacs is free software; you can redistribute it and/or modify it | |
7 under the terms of the GNU General Public License as published by the | |
8 Free Software Foundation; either version 2, or (at your option) any | |
9 later version. | |
10 | |
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
14 for more details. | |
15 | |
16 You should have received a copy of the GNU General Public License | |
17 along with XEmacs; see the file COPYING. If not, write to | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
1993
diff
changeset
|
18 the Free Software Foundation, Inc., 51 Franklin St - Fifth Floor, |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
1993
diff
changeset
|
19 Boston, MA 02111-1301, USA. */ |
1983 | 20 |
21 /* Synched up with: Not in FSF. */ | |
22 | |
23 #include <config.h> | |
24 #include <limits.h> | |
25 #include <math.h> | |
26 #include "lisp.h" | |
27 | |
28 static MINT *bignum_bytesize, *bignum_long_sign_bit, *bignum_one, *bignum_two; | |
29 MINT *bignum_zero, *intern_bignum; | |
30 MINT *bignum_min_int, *bignum_max_int, *bignum_max_uint; | |
31 MINT *bignum_min_long, *bignum_max_long, *bignum_max_ulong; | |
32 short div_rem; | |
33 | |
34 char * | |
35 bignum_to_string (bignum b, int base) | |
36 { | |
37 REGISTER unsigned int i; | |
38 unsigned int bufsize = 128U, index = 0U; | |
39 int sign; | |
40 char *buffer = xnew_array (char, 128), *retval; | |
41 MINT *quo = MP_ITOM (0); | |
42 short rem; | |
43 | |
44 /* FIXME: signal something if base is < 2 or doesn't fit into a short. */ | |
45 | |
46 /* Save the sign for later */ | |
47 sign = MP_MCMP (b, bignum_zero); | |
48 | |
49 if (sign == 0) | |
50 { | |
51 XREALLOC_ARRAY (buffer, char, 2); | |
52 buffer[0] = '0'; | |
53 buffer[1] = '\0'; | |
54 return buffer; | |
55 } | |
56 /* Copy abs(b) into quo for destructive modification */ | |
57 else if (sign < 0) | |
58 MP_MSUB (bignum_zero, b, quo); | |
59 else | |
60 MP_MOVE (b, quo); | |
61 | |
62 quo = MP_ITOM (0); | |
63 | |
64 /* Loop over the digits of b (in BASE) and place each one into buffer */ | |
65 for (i = 0U; MP_MCMP(quo, bignum_zero) > 0; i++) | |
66 { | |
67 MP_SDIV (quo, base, quo, &rem); | |
68 if (index == bufsize) | |
69 { | |
70 bufsize <<= 1; | |
71 XREALLOC_ARRAY (buffer, char, bufsize); | |
72 } | |
73 buffer[index++] = rem < 10 ? rem + '0' : rem - 10 + 'a'; | |
74 } | |
75 MP_MFREE (quo); | |
76 | |
77 /* Reverse the digits, maybe add a minus sign, and add a null terminator */ | |
78 bufsize = index + (sign < 0 ? 1 : 0) + 1; | |
79 retval = xnew_array (char, bufsize); | |
80 if (sign < 0) | |
81 { | |
82 retval[0] = '-'; | |
83 i = 1; | |
84 } | |
85 else | |
86 i = 0; | |
87 for (; i < bufsize - 1; i++) | |
88 retval[i] = buffer[--index]; | |
89 retval[bufsize - 1] = '\0'; | |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4802
diff
changeset
|
90 xfree (buffer); |
1983 | 91 return retval; |
92 } | |
93 | |
94 #define BIGNUM_TO_TYPE(type,accumtype) do { \ | |
95 MP_MULT (b, quo, quo); \ | |
96 for (i = 0U; i < sizeof(type); i++) \ | |
97 { \ | |
98 MP_SDIV (quo, 256, quo, &rem); \ | |
99 retval |= ((accumtype) rem) << (8 * i); \ | |
100 } \ | |
101 MP_MFREE (quo); \ | |
102 } while (0) | |
103 | |
104 int | |
105 bignum_to_int (bignum b) | |
106 { | |
107 short rem, sign; | |
108 unsigned int retval = 0; | |
109 REGISTER unsigned int i; | |
110 MINT *quo; | |
111 | |
112 sign = MP_MCMP (b, bignum_zero) < 0 ? -1 : 1; | |
113 quo = MP_ITOM (sign); | |
114 BIGNUM_TO_TYPE (int, unsigned int); | |
115 return ((int) retval) * sign; | |
116 } | |
117 | |
118 unsigned int | |
119 bignum_to_uint (bignum b) | |
120 { | |
121 short rem; | |
122 unsigned int retval = 0U; | |
123 REGISTER unsigned int i; | |
124 MINT *quo; | |
125 | |
126 quo = MP_ITOM (MP_MCMP (b, bignum_zero) < 0 ? -1 : 1); | |
127 BIGNUM_TO_TYPE (unsigned int, unsigned int); | |
128 return retval; | |
129 } | |
130 | |
131 long | |
132 bignum_to_long (bignum b) | |
133 { | |
134 short rem, sign; | |
135 unsigned long retval = 0L; | |
136 REGISTER unsigned int i; | |
137 MINT *quo; | |
138 | |
139 sign = MP_MCMP (b, bignum_zero) < 0 ? -1 : 1; | |
140 quo = MP_ITOM (sign); | |
141 BIGNUM_TO_TYPE (long, unsigned long); | |
142 return ((long) retval) * sign; | |
143 } | |
144 | |
145 unsigned long | |
146 bignum_to_ulong (bignum b) | |
147 { | |
148 short rem; | |
149 unsigned long retval = 0UL; | |
150 REGISTER unsigned int i; | |
151 MINT *quo; | |
152 | |
153 quo = MP_ITOM (MP_MCMP (b, bignum_zero) < 0 ? -1 : 1); | |
154 BIGNUM_TO_TYPE (unsigned long, unsigned long); | |
155 return retval; | |
156 } | |
157 | |
158 double | |
159 bignum_to_double (bignum b) | |
160 { | |
161 short rem, sign; | |
1990 | 162 double retval = 0.0, factor = 1.0; |
1983 | 163 REGISTER unsigned int i; |
164 MINT *quo; | |
165 | |
166 sign = MP_MCMP (b, bignum_zero) < 0 ? -1 : 1; | |
167 quo = MP_ITOM (sign); | |
168 MP_MULT (b, quo, quo); | |
1990 | 169 for (i = 0U; MP_MCMP (quo, bignum_zero) > 0; i++) |
1983 | 170 { |
171 MP_SDIV (quo, 256, quo, &rem); | |
1990 | 172 retval += rem * factor; |
173 factor *= 256.0; | |
1983 | 174 } |
175 MP_MFREE (quo); | |
176 return retval * sign; | |
177 } | |
178 | |
179 static short | |
180 char_to_number (char c) | |
181 { | |
182 if (c >= '0' && c <= '9') | |
183 return c - '0'; | |
184 if (c >= 'a' && c <= 'z') | |
185 return c - 'a' + 10; | |
186 if (c >= 'A' && c <= 'Z') | |
187 return c - 'A' + 10; | |
188 return -1; | |
189 } | |
190 | |
191 int | |
192 bignum_set_string (bignum b, const char *s, int base) | |
193 { | |
194 MINT *mbase; | |
195 short digit; | |
1993 | 196 int neg = 0; |
1983 | 197 |
198 if (base == 0) | |
199 { | |
200 if (s[0] == '0' && (s[1] == 'x' || s[1] == 'X')) | |
201 { | |
202 base = 16; | |
203 s += 2; | |
204 } | |
205 else if (*s == '0') | |
206 { | |
207 base = 8; | |
208 s++; | |
209 } | |
210 else | |
211 base = 10; | |
212 } | |
213 | |
214 /* FIXME: signal something if base is < 2 or doesn't fit into a short. */ | |
215 | |
1993 | 216 if (*s == '-') |
217 { | |
218 s++; | |
219 neg = 1; | |
220 } | |
221 | |
1983 | 222 mbase = MP_ITOM ((short) base); |
223 MP_MOVE (bignum_zero, b); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
1993
diff
changeset
|
224 |
1983 | 225 for (digit = char_to_number (*s); digit >= 0 && digit < base; |
226 digit = char_to_number (*++s)) | |
227 { | |
228 MINT *temp; | |
229 | |
230 MP_MULT (b, mbase, b); | |
231 temp = MP_ITOM (digit); | |
232 MP_MADD (b, temp, b); | |
233 MP_MFREE (temp); | |
234 } | |
235 | |
1993 | 236 if (neg) |
237 MP_MSUB (bignum_zero, b, b); | |
238 | |
1983 | 239 return (digit >= 0) ? -1 : 0; |
240 } | |
241 | |
242 void | |
243 bignum_set_long (MINT *b, long l) | |
244 { | |
245 /* Negative l is hard, not least because -LONG_MIN == LONG_MIN. We pretend | |
246 that l is unsigned, then subtract off the amount equal to the sign bit. */ | |
247 bignum_set_ulong (b, (unsigned long) l); | |
248 if (l < 0L) | |
249 MP_MSUB (b, bignum_long_sign_bit, b); | |
250 } | |
251 | |
252 void | |
253 bignum_set_ulong (bignum b, unsigned long l) | |
254 { | |
255 REGISTER unsigned int i; | |
256 MINT *multiplier = MP_ITOM (1); | |
257 | |
258 MP_MOVE (bignum_zero, b); | |
259 for (i = 0UL; l > 0UL; l >>= 8, i++) | |
260 { | |
261 MINT *temp = MP_ITOM ((short) (l & 255)); | |
262 MP_MULT (multiplier, temp, temp); | |
263 MP_MADD (b, temp, b); | |
264 MP_MULT (multiplier, bignum_bytesize, multiplier); | |
265 MP_MFREE (temp); | |
266 } | |
267 MP_MFREE (multiplier); | |
268 } | |
269 | |
270 void | |
271 bignum_set_double (bignum b, double d) | |
272 { | |
273 REGISTER unsigned int i; | |
274 int negative = (d < 0) ? 1 : 0; | |
275 MINT *multiplier = MP_ITOM (1); | |
276 | |
277 MP_MOVE (bignum_zero, b); | |
278 if (negative) | |
279 d = -d; | |
280 for (i = 0UL; d > 0.0; d /= 256, i++) | |
281 { | |
282 MINT *temp = MP_ITOM ((short) fmod (d, 256.0)); | |
283 MP_MULT (multiplier, temp, temp); | |
284 MP_MADD (b, temp, b); | |
285 MP_MULT (multiplier, bignum_bytesize, multiplier); | |
286 MP_MFREE (temp); | |
287 } | |
288 MP_MFREE (multiplier); | |
289 if (negative) | |
290 MP_MSUB (bignum_zero, b, b); | |
291 } | |
292 | |
293 /* Return nonzero if b1 is exactly divisible by b2 */ | |
294 int | |
295 bignum_divisible_p (bignum b1, bignum b2) | |
296 { | |
297 int retval; | |
298 MINT *rem = MP_ITOM (0); | |
299 MP_MDIV (b1, b2, intern_bignum, rem); | |
300 retval = (MP_MCMP (rem, bignum_zero) == 0); | |
301 MP_MFREE (rem); | |
302 return retval; | |
303 } | |
304 | |
305 void bignum_ceil (bignum quotient, bignum N, bignum D) | |
306 { | |
307 MP_MDIV (N, D, quotient, intern_bignum); | |
308 if (MP_MCMP (intern_bignum, bignum_zero) > 0 && | |
309 MP_MCMP (quotient, bignum_zero) > 0) | |
310 MP_MADD (quotient, bignum_one, quotient); | |
311 } | |
312 | |
313 void bignum_floor (bignum quotient, bignum N, bignum D) | |
314 { | |
315 MP_MDIV (N, D, quotient, intern_bignum); | |
316 if (MP_MCMP (intern_bignum, bignum_zero) > 0 && | |
317 MP_MCMP (quotient, bignum_zero) < 0) | |
318 MP_MSUB (quotient, bignum_one, quotient); | |
319 } | |
320 | |
321 /* RESULT = N to the POWth power */ | |
322 void | |
323 bignum_pow (bignum result, bignum n, unsigned long pow) | |
324 { | |
325 MP_MOVE (bignum_one, result); | |
326 for ( ; pow > 0UL; pow--) | |
327 MP_MULT (result, n, result); | |
328 } | |
329 | |
330 /* lcm(b1,b2) = b1 * b2 / gcd(b1, b2) */ | |
331 void | |
332 bignum_lcm (bignum result, bignum b1, bignum b2) | |
333 { | |
334 MP_MULT (b1, b2, result); | |
335 MP_GCD (b1, b2, intern_bignum); | |
336 MP_MDIV (result, intern_bignum, result, intern_bignum); | |
337 } | |
338 | |
339 /* FIXME: We can't handle negative args, so right now we just make them | |
340 positive before doing anything else. How should we really handle negative | |
341 args? */ | |
342 #define bignum_bit_op(result, b1, b2, op) \ | |
343 REGISTER unsigned int i; \ | |
344 MINT *multiplier = MP_ITOM (1), *n1 = MP_ITOM (0), *n2 = MP_ITOM (0); \ | |
345 \ | |
346 if (MP_MCMP (bignum_zero, b1) > 0) \ | |
347 MP_MSUB (bignum_zero, b1, n1); \ | |
348 else \ | |
349 MP_MOVE (b1, n1); \ | |
350 if (MP_MCMP (bignum_zero, b2) > 0) \ | |
351 MP_MSUB (bignum_zero, b2, n2); \ | |
352 else \ | |
353 MP_MOVE (b2, n2); \ | |
354 \ | |
355 MP_MOVE (bignum_zero, result); \ | |
356 \ | |
357 for (i = 0UL; MP_MCMP (bignum_zero, n1) < 0 && \ | |
358 MP_MCMP (bignum_zero, n2) < 0; i++) \ | |
359 { \ | |
360 short byte1, byte2; \ | |
361 MINT *temp; \ | |
362 \ | |
363 MP_SDIV (n1, 256, n1, &byte1); \ | |
364 MP_SDIV (n2, 256, n2, &byte2); \ | |
365 temp = MP_ITOM (byte1 op byte2); \ | |
366 MP_MULT (multiplier, temp, temp); \ | |
367 MP_MADD (result, temp, result); \ | |
368 MP_MULT (multiplier, bignum_bytesize, multiplier); \ | |
369 MP_MFREE (temp); \ | |
370 } \ | |
371 MP_MFREE (n2); \ | |
372 MP_MFREE (n1); \ | |
373 MP_MFREE (multiplier) | |
374 | |
375 void | |
376 bignum_and (bignum result, bignum b1, bignum b2) | |
377 { | |
378 bignum_bit_op (result, b1, b2, &); | |
379 } | |
380 | |
381 void | |
382 bignum_ior (bignum result, bignum b1, bignum b2) | |
383 { | |
384 bignum_bit_op (result, b1, b2, |); | |
385 } | |
386 | |
387 void | |
388 bignum_xor (bignum result, bignum b1, bignum b2) | |
389 { | |
390 bignum_bit_op (result, b1, b2, ^); | |
391 } | |
392 | |
393 /* NOT is not well-defined for bignums ... where do you stop flipping bits? | |
394 We just flip until we see the last one. This is probably a bad idea. */ | |
395 void | |
396 bignum_not (bignum result, bignum b) | |
397 { | |
398 REGISTER unsigned int i; | |
399 MINT *multiplier = MP_ITOM (1), *n = MP_ITOM (0); | |
400 | |
401 if (MP_MCMP (bignum_zero, b) > 0) | |
402 MP_MSUB (bignum_zero, b, n); | |
403 else | |
404 MP_MOVE (b, n); | |
405 | |
406 MP_MOVE (bignum_zero, result); | |
407 | |
408 for (i = 0UL; MP_MCMP (bignum_zero, n) < 0; i++) | |
409 { | |
410 short byte; | |
411 MINT *temp; | |
412 | |
413 MP_SDIV (n, 256, n, &byte); | |
414 temp = MP_ITOM (~byte); | |
415 MP_MULT (multiplier, temp, temp); | |
416 MP_MADD (result, temp, result); | |
417 MP_MULT (multiplier, bignum_bytesize, multiplier); | |
418 MP_MFREE (temp); | |
419 } | |
420 MP_MFREE (n); | |
421 MP_MFREE (multiplier); | |
422 } | |
423 | |
424 void | |
425 bignum_setbit (bignum b, unsigned long bit) | |
426 { | |
427 bignum_pow (intern_bignum, bignum_two, bit); | |
428 bignum_ior (b, b, intern_bignum); | |
429 } | |
430 | |
431 /* This is so evil, even I feel queasy. */ | |
432 void | |
433 bignum_clrbit (bignum b, unsigned long bit) | |
434 { | |
435 MINT *num = MP_ITOM (0); | |
436 | |
437 /* See if the bit is already set, and subtract it off if not */ | |
438 MP_MOVE (b, intern_bignum); | |
439 bignum_pow (num, bignum_two, bit); | |
440 bignum_ior (intern_bignum, intern_bignum, num); | |
441 if (MP_MCMP (b, intern_bignum) == 0) | |
442 MP_MSUB (b, num, b); | |
443 MP_MFREE (num); | |
444 } | |
445 | |
446 int | |
447 bignum_testbit (bignum b, unsigned long bit) | |
448 { | |
449 bignum_pow (intern_bignum, bignum_two, bit); | |
450 bignum_and (intern_bignum, b, intern_bignum); | |
451 return MP_MCMP (intern_bignum, bignum_zero); | |
452 } | |
453 | |
454 void | |
455 bignum_lshift (bignum result, bignum b, unsigned long bits) | |
456 { | |
457 bignum_pow (intern_bignum, bignum_two, bits); | |
458 MP_MULT (b, intern_bignum, result); | |
459 } | |
460 | |
461 void | |
462 bignum_rshift (bignum result, bignum b, unsigned long bits) | |
463 { | |
464 bignum_pow (intern_bignum, bignum_two, bits); | |
465 MP_MDIV (b, intern_bignum, result, intern_bignum); | |
466 } | |
467 | |
468 void bignum_random_seed(unsigned long seed) | |
469 { | |
470 /* FIXME: Implement me */ | |
471 } | |
472 | |
473 void bignum_random(bignum result, bignum limit) | |
474 { | |
475 /* FIXME: Implement me */ | |
476 MP_MOVE (bignum_zero, result); | |
477 } | |
478 | |
479 void | |
480 init_number_mp () | |
481 { | |
482 REGISTER unsigned int i; | |
483 | |
484 bignum_zero = MP_ITOM (0); | |
485 bignum_one = MP_ITOM (1); | |
486 bignum_two = MP_ITOM (2); | |
487 | |
488 /* intern_bignum holds throwaway values from macro expansions in | |
489 number-mp.h. Its value is immaterial. */ | |
490 intern_bignum = MP_ITOM (0); | |
491 | |
492 /* bignum_bytesize holds the number of bits in a byte. */ | |
493 bignum_bytesize = MP_ITOM (256); | |
494 | |
495 /* bignum_long_sign_bit holds an adjustment for negative longs. */ | |
496 bignum_long_sign_bit = MP_ITOM (256); | |
497 for (i = 1UL; i < sizeof (long); i++) | |
498 MP_MULT (bignum_bytesize, bignum_long_sign_bit, bignum_long_sign_bit); | |
499 | |
500 /* The MP interface only supports turning short ints into MINTs, so we have | |
501 to set these the hard way. */ | |
502 | |
503 bignum_min_int = MP_ITOM (0); | |
504 bignum_set_long (bignum_min_int, INT_MIN); | |
505 | |
506 bignum_max_int = MP_ITOM (0); | |
507 bignum_set_long (bignum_max_int, INT_MAX); | |
508 | |
509 bignum_max_uint = MP_ITOM (0); | |
510 bignum_set_ulong (bignum_max_uint, UINT_MAX); | |
511 | |
512 bignum_min_long = MP_ITOM (0); | |
513 bignum_set_long (bignum_min_long, LONG_MIN); | |
514 | |
515 bignum_max_long = MP_ITOM (0); | |
516 bignum_set_long (bignum_max_long, LONG_MAX); | |
517 | |
518 bignum_max_ulong = MP_ITOM (0); | |
519 bignum_set_ulong (bignum_max_ulong, ULONG_MAX); | |
520 } |