1 ;;; calc-bin.el --- binary functions for Calc
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
5 ;; Author: David Gillespie <daveg@synaptics.com>
6 ;; Maintainer: Colin Walters <walters@debian.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
29 ;; This file is autoloaded from calc-ext.el.
34 (defun calc-Need-calc-bin () nil
)
37 ;;; b-prefix binary commands.
42 (calc-enter-result 2 "and"
43 (append '(calcFunc-and)
45 (and n
(list (prefix-numeric-value n
)))))))
50 (calc-enter-result 2 "or"
51 (append '(calcFunc-or)
53 (and n
(list (prefix-numeric-value n
)))))))
58 (calc-enter-result 2 "xor"
59 (append '(calcFunc-xor)
61 (and n
(list (prefix-numeric-value n
)))))))
66 (calc-enter-result 2 "diff"
67 (append '(calcFunc-diff)
69 (and n
(list (prefix-numeric-value n
)))))))
74 (calc-enter-result 1 "not"
75 (append '(calcFunc-not)
77 (and n
(list (prefix-numeric-value n
)))))))
79 (defun calc-lshift-binary (n)
82 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
83 (calc-enter-result hyp
"lsh"
84 (append '(calcFunc-lsh)
86 (and n
(list (prefix-numeric-value n
))))))))
88 (defun calc-rshift-binary (n)
91 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
92 (calc-enter-result hyp
"rsh"
93 (append '(calcFunc-rsh)
95 (and n
(list (prefix-numeric-value n
))))))))
97 (defun calc-lshift-arith (n)
100 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
101 (calc-enter-result hyp
"ash"
102 (append '(calcFunc-ash)
103 (calc-top-list-n hyp
)
104 (and n
(list (prefix-numeric-value n
))))))))
106 (defun calc-rshift-arith (n)
109 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
110 (calc-enter-result hyp
"rash"
111 (append '(calcFunc-rash)
112 (calc-top-list-n hyp
)
113 (and n
(list (prefix-numeric-value n
))))))))
115 (defun calc-rotate-binary (n)
118 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
119 (calc-enter-result hyp
"rot"
120 (append '(calcFunc-rot)
121 (calc-top-list-n hyp
)
122 (and n
(list (prefix-numeric-value n
))))))))
127 (calc-enter-result 1 "clip"
128 (append '(calcFunc-clip)
130 (and n
(list (prefix-numeric-value n
)))))))
132 (defun calc-word-size (n)
135 (or n
(setq n
(read-string (format "Binary word size: (default %d) "
137 (setq n
(if (stringp n
)
140 (if (string-match "\\`[-+]?[0-9]+\\'" n
)
142 (error "Expected an integer")))
143 (prefix-numeric-value n
)))
144 (or (= n calc-word-size
)
145 (if (> (math-abs n
) 100)
146 (calc-change-mode 'calc-word-size n calc-leading-zeros
)
147 (calc-change-mode '(calc-word-size calc-previous-modulo
)
148 (list n
(math-power-of-2 (math-abs n
)))
149 calc-leading-zeros
)))
151 (message "Binary word size is %d bits (2's complement)" (- n
))
152 (message "Binary word size is %d bits" n
))))
158 ;;; d-prefix mode commands.
160 (defun calc-radix (n)
161 (interactive "NDisplay radix (2-36): ")
163 (if (and (>= n
2) (<= n
36))
165 (calc-change-mode 'calc-number-radix n t
)
166 ;; also change global value so minibuffer sees it
167 (setq-default calc-number-radix calc-number-radix
))
168 (setq n calc-number-radix
))
169 (message "Number radix is %d" n
)))
171 (defun calc-decimal-radix ()
175 (defun calc-binary-radix ()
179 (defun calc-octal-radix ()
183 (defun calc-hex-radix ()
187 (defun calc-leading-zeros (n)
190 (if (calc-change-mode 'calc-leading-zeros n t t
)
191 (message "Zero-padding integers to %d digits (assuming radix %d)"
192 (let* ((calc-internal-prec 6))
193 (math-compute-max-digits (math-abs calc-word-size
)
196 (message "Omitting leading zeros on integers"))))
199 (defvar math-power-of-2-cache
(list 1 2 4 8 16 32 64 128 256 512 1024))
200 (defvar math-big-power-of-2-cache nil
)
201 (defun math-power-of-2 (n) ; [I I] [Public]
202 (if (and (natnump n
) (<= n
100))
203 (or (nth n math-power-of-2-cache
)
204 (let* ((i (length math-power-of-2-cache
))
205 (val (nth (1- i
) math-power-of-2-cache
)))
207 (setq val
(math-mul val
2)
208 math-power-of-2-cache
(nconc math-power-of-2-cache
212 (let ((found (assq n math-big-power-of-2-cache
)))
215 (let ((po2 (math-ipow 2 n
)))
216 (setq math-big-power-of-2-cache
217 (cons (cons n po2
) math-big-power-of-2-cache
))
220 (defun math-integer-log2 (n) ; [I I] [Public]
222 (p math-power-of-2-cache
)
224 (while (and p
(Math-natnum-lessp (setq val
(car p
)) n
))
230 (while (Math-natnum-lessp
232 (setq val
(math-mul val
2))
233 (setq math-power-of-2-cache
(nconc math-power-of-2-cache
243 ;;; Bitwise operations.
245 (defun calcFunc-and (a b
&optional w
) ; [I I I] [Public]
246 (cond ((Math-messy-integerp w
)
247 (calcFunc-and a b
(math-trunc w
)))
248 ((and w
(not (integerp w
)))
249 (math-reject-arg w
'fixnump
))
250 ((and (integerp a
) (integerp b
))
251 (math-clip (logand a b
) w
))
252 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
253 (math-binary-modulo-args 'calcFunc-and a b w
))
254 ((not (Math-num-integerp a
))
255 (math-reject-arg a
'integerp
))
256 ((not (Math-num-integerp b
))
257 (math-reject-arg b
'integerp
))
258 (t (math-clip (cons 'bigpos
259 (math-and-bignum (math-binary-arg a w
)
260 (math-binary-arg b w
)))
263 (defun math-binary-arg (a w
)
264 (if (not (Math-integerp a
))
265 (setq a
(math-trunc a
)))
266 (if (Math-integer-negp a
)
267 (math-not-bignum (cdr (math-bignum-test (math-sub -
1 a
)))
268 (math-abs (if w
(math-trunc w
) calc-word-size
)))
269 (cdr (Math-bignum-test a
))))
271 (defun math-binary-modulo-args (f a b w
)
273 (if (eq (car-safe a
) 'mod
)
277 (if (eq (car-safe b
) 'mod
)
278 (if (equal mod
(nth 2 b
))
280 (math-reject-arg b
"*Inconsistent modulos"))))
283 (if (Math-messy-integerp mod
)
284 (setq mod
(math-trunc mod
))
285 (or (Math-integerp mod
)
286 (math-reject-arg mod
'integerp
)))
287 (let ((bits (math-integer-log2 mod
)))
292 "*Warning: Modulo inconsistent with word size"))
294 (calc-record-why "*Warning: Modulo is not a power of 2"))
300 (defun math-and-bignum (a b
) ; [l l l]
302 (let ((qa (math-div-bignum-digit a
512))
303 (qb (math-div-bignum-digit b
512)))
304 (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa
))
305 (math-norm-bignum (car qb
)))
307 (logand (cdr qa
) (cdr qb
))))))
309 (defun calcFunc-or (a b
&optional w
) ; [I I I] [Public]
310 (cond ((Math-messy-integerp w
)
311 (calcFunc-or a b
(math-trunc w
)))
312 ((and w
(not (integerp w
)))
313 (math-reject-arg w
'fixnump
))
314 ((and (integerp a
) (integerp b
))
315 (math-clip (logior a b
) w
))
316 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
317 (math-binary-modulo-args 'calcFunc-or a b w
))
318 ((not (Math-num-integerp a
))
319 (math-reject-arg a
'integerp
))
320 ((not (Math-num-integerp b
))
321 (math-reject-arg b
'integerp
))
322 (t (math-clip (cons 'bigpos
323 (math-or-bignum (math-binary-arg a w
)
324 (math-binary-arg b w
)))
327 (defun math-or-bignum (a b
) ; [l l l]
329 (let ((qa (math-div-bignum-digit a
512))
330 (qb (math-div-bignum-digit b
512)))
331 (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa
))
332 (math-norm-bignum (car qb
)))
334 (logior (cdr qa
) (cdr qb
))))))
336 (defun calcFunc-xor (a b
&optional w
) ; [I I I] [Public]
337 (cond ((Math-messy-integerp w
)
338 (calcFunc-xor a b
(math-trunc w
)))
339 ((and w
(not (integerp w
)))
340 (math-reject-arg w
'fixnump
))
341 ((and (integerp a
) (integerp b
))
342 (math-clip (logxor a b
) w
))
343 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
344 (math-binary-modulo-args 'calcFunc-xor a b w
))
345 ((not (Math-num-integerp a
))
346 (math-reject-arg a
'integerp
))
347 ((not (Math-num-integerp b
))
348 (math-reject-arg b
'integerp
))
349 (t (math-clip (cons 'bigpos
350 (math-xor-bignum (math-binary-arg a w
)
351 (math-binary-arg b w
)))
354 (defun math-xor-bignum (a b
) ; [l l l]
356 (let ((qa (math-div-bignum-digit a
512))
357 (qb (math-div-bignum-digit b
512)))
358 (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa
))
359 (math-norm-bignum (car qb
)))
361 (logxor (cdr qa
) (cdr qb
))))))
363 (defun calcFunc-diff (a b
&optional w
) ; [I I I] [Public]
364 (cond ((Math-messy-integerp w
)
365 (calcFunc-diff a b
(math-trunc w
)))
366 ((and w
(not (integerp w
)))
367 (math-reject-arg w
'fixnump
))
368 ((and (integerp a
) (integerp b
))
369 (math-clip (logand a
(lognot b
)) w
))
370 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
371 (math-binary-modulo-args 'calcFunc-diff a b w
))
372 ((not (Math-num-integerp a
))
373 (math-reject-arg a
'integerp
))
374 ((not (Math-num-integerp b
))
375 (math-reject-arg b
'integerp
))
376 (t (math-clip (cons 'bigpos
377 (math-diff-bignum (math-binary-arg a w
)
378 (math-binary-arg b w
)))
381 (defun math-diff-bignum (a b
) ; [l l l]
383 (let ((qa (math-div-bignum-digit a
512))
384 (qb (math-div-bignum-digit b
512)))
385 (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa
))
386 (math-norm-bignum (car qb
)))
388 (logand (cdr qa
) (lognot (cdr qb
)))))))
390 (defun calcFunc-not (a &optional w
) ; [I I] [Public]
391 (cond ((Math-messy-integerp w
)
392 (calcFunc-not a
(math-trunc w
)))
393 ((eq (car-safe a
) 'mod
)
394 (math-binary-modulo-args 'calcFunc-not a nil w
))
395 ((and w
(not (integerp w
)))
396 (math-reject-arg w
'fixnump
))
397 ((not (Math-num-integerp a
))
398 (math-reject-arg a
'integerp
))
399 ((< (or w
(setq w calc-word-size
)) 0)
400 (math-clip (calcFunc-not a
(- w
)) w
))
403 (math-not-bignum (math-binary-arg a w
)
406 (defun math-not-bignum (a w
) ; [l l]
407 (let ((q (math-div-bignum-digit a
512)))
409 (list (logand (lognot (cdr q
))
411 (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q
))
414 (logxor (cdr q
) 511)))))
416 (defun calcFunc-lsh (a &optional n w
) ; [I I] [Public]
417 (setq a
(math-trunc a
)
418 n
(if n
(math-trunc n
) 1))
419 (if (eq (car-safe a
) 'mod
)
420 (math-binary-modulo-args 'calcFunc-lsh a n w
)
421 (setq w
(if w
(math-trunc w
) calc-word-size
))
423 (math-reject-arg w
'fixnump
))
424 (or (Math-integerp a
)
425 (math-reject-arg a
'integerp
))
426 (or (Math-integerp n
)
427 (math-reject-arg n
'integerp
))
429 (math-clip (calcFunc-lsh a n
(- w
)) w
)
430 (if (Math-integer-negp a
)
431 (setq a
(math-clip a w
)))
432 (cond ((or (Math-lessp n
(- w
))
436 (math-quotient (math-clip a w
) (math-power-of-2 (- n
))))
438 (math-clip (math-mul a
(math-power-of-2 n
)) w
))))))
440 (defun calcFunc-rsh (a &optional n w
) ; [I I] [Public]
441 (calcFunc-lsh a
(math-neg (or n
1)) w
))
443 (defun calcFunc-ash (a &optional n w
) ; [I I] [Public]
447 (setq a
(math-trunc a
)
448 n
(if n
(math-trunc n
) 1))
449 (if (eq (car-safe a
) 'mod
)
450 (math-binary-modulo-args 'calcFunc-ash a n w
)
451 (setq w
(if w
(math-trunc w
) calc-word-size
))
453 (math-reject-arg w
'fixnump
))
454 (or (Math-integerp a
)
455 (math-reject-arg a
'integerp
))
456 (or (Math-integerp n
)
457 (math-reject-arg n
'integerp
))
459 (math-clip (calcFunc-ash a n
(- w
)) w
)
460 (if (Math-integer-negp a
)
461 (setq a
(math-clip a w
)))
462 (let ((two-to-sizem1 (math-power-of-2 (1- w
)))
463 (sh (calcFunc-lsh a n w
)))
464 (cond ((Math-natnum-lessp a two-to-sizem1
)
466 ((Math-lessp n
(- 1 w
))
467 (math-add (math-mul two-to-sizem1
2) -
1))
468 (t (let ((two-to-n (math-power-of-2 (- n
))))
469 (math-add (calcFunc-lsh (math-add two-to-n -
1)
473 (defun calcFunc-rash (a &optional n w
) ; [I I] [Public]
474 (calcFunc-ash a
(math-neg (or n
1)) w
))
476 (defun calcFunc-rot (a &optional n w
) ; [I I] [Public]
477 (setq a
(math-trunc a
)
478 n
(if n
(math-trunc n
) 1))
479 (if (eq (car-safe a
) 'mod
)
480 (math-binary-modulo-args 'calcFunc-rot a n w
)
481 (setq w
(if w
(math-trunc w
) calc-word-size
))
483 (math-reject-arg w
'fixnump
))
484 (or (Math-integerp a
)
485 (math-reject-arg a
'integerp
))
486 (or (Math-integerp n
)
487 (math-reject-arg n
'integerp
))
489 (math-clip (calcFunc-rot a n
(- w
)) w
)
490 (if (Math-integer-negp a
)
491 (setq a
(math-clip a w
)))
492 (cond ((or (Math-integer-negp n
)
493 (not (Math-natnum-lessp n w
)))
494 (calcFunc-rot a
(math-mod n w
) w
))
496 (math-add (calcFunc-lsh a
(- n w
) w
)
497 (calcFunc-lsh a n w
)))))))
499 (defun math-clip (a &optional w
) ; [I I] [Public]
500 (cond ((Math-messy-integerp w
)
501 (math-clip a
(math-trunc w
)))
502 ((eq (car-safe a
) 'mod
)
503 (math-binary-modulo-args 'math-clip a nil w
))
504 ((and w
(not (integerp w
)))
505 (math-reject-arg w
'fixnump
))
506 ((not (Math-num-integerp a
))
507 (math-reject-arg a
'integerp
))
508 ((< (or w
(setq w calc-word-size
)) 0)
509 (setq a
(math-clip a
(- w
)))
510 (if (Math-natnum-lessp a
(math-power-of-2 (- -
1 w
)))
512 (math-sub a
(math-power-of-2 (- w
)))))
514 (math-normalize (cons 'bigpos
(math-binary-arg a w
))))
515 ((and (integerp a
) (< a
1000000))
518 (logand a
(1- (lsh 1 w
)))))
522 (math-clip-bignum (cdr (math-bignum-test (math-trunc a
)))
525 (defalias 'calcFunc-clip
'math-clip
)
527 (defun math-clip-bignum (a w
) ; [l l]
528 (let ((q (math-div-bignum-digit a
512)))
530 (list (logand (cdr q
)
532 (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q
))
537 (defvar math-max-digits-cache nil
)
538 (defun math-compute-max-digits (w r
)
539 (let* ((pair (+ (* r
100000) w
))
540 (res (assq pair math-max-digits-cache
)))
543 (let* ((calc-command-flags nil
)
544 (digs (math-ceiling (math-div w
(math-real-log2 r
)))))
545 (setq math-max-digits-cache
(cons (cons pair digs
)
546 math-max-digits-cache
))
549 (defvar math-log2-cache
(list '(2 .
1)
552 '(10 .
(float 332193 -
5))
555 (defun math-real-log2 (x) ;;; calc-internal-prec must be 6
556 (let ((res (assq x math-log2-cache
)))
559 (let* ((calc-symbolic-mode nil
)
560 (calc-display-working-message nil
)
561 (log (calcFunc-log x
2)))
562 (setq math-log2-cache
(cons (cons x log
) math-log2-cache
))
565 (defconst math-radix-digits
["0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
566 "A" "B" "C" "D" "E" "F" "G" "H" "I" "J"
567 "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T"
568 "U" "V" "W" "X" "Y" "Z"])
570 (defsubst math-format-radix-digit
(a) ; [X D]
571 (aref math-radix-digits a
))
573 (defun math-format-radix (a) ; [X S]
574 (if (< a calc-number-radix
)
576 (concat "-" (math-format-radix (- a
)))
577 (math-format-radix-digit a
))
580 (setq s
(concat (math-format-radix-digit (% a calc-number-radix
)) s
)
581 a
(/ a calc-number-radix
)))
584 (defconst math-binary-digits
["000" "001" "010" "011"
585 "100" "101" "110" "111"])
586 (defun math-format-binary (a) ; [X S]
589 (concat "-" (math-format-binary (- a
)))
590 (math-format-radix a
))
593 (setq s
(concat (aref math-binary-digits
(% a
8)) s
)
595 (concat (math-format-radix a
) s
))))
597 (defun math-format-bignum-radix (a) ; [X L]
600 (< (car a
) calc-number-radix
))
601 (math-format-radix-digit (car a
)))
603 (let ((q (math-div-bignum-digit a calc-number-radix
)))
604 (concat (math-format-bignum-radix (math-norm-bignum (car q
)))
605 (math-format-radix-digit (cdr q
)))))))
607 (defun math-format-bignum-binary (a) ; [X L]
610 (math-format-binary (car a
)))
612 (let ((q (math-div-bignum-digit a
512)))
613 (concat (math-format-bignum-binary (math-norm-bignum (car q
)))
614 (aref math-binary-digits
(/ (cdr q
) 64))
615 (aref math-binary-digits
(%
(/ (cdr q
) 8) 8))
616 (aref math-binary-digits
(%
(cdr q
) 8)))))))
618 (defun math-format-bignum-octal (a) ; [X L]
621 (math-format-radix (car a
)))
623 (let ((q (math-div-bignum-digit a
512)))
624 (concat (math-format-bignum-octal (math-norm-bignum (car q
)))
625 (math-format-radix-digit (/ (cdr q
) 64))
626 (math-format-radix-digit (%
(/ (cdr q
) 8) 8))
627 (math-format-radix-digit (%
(cdr q
) 8)))))))
629 (defun math-format-bignum-hex (a) ; [X L]
632 (math-format-radix (car a
)))
634 (let ((q (math-div-bignum-digit a
256)))
635 (concat (math-format-bignum-hex (math-norm-bignum (car q
)))
636 (math-format-radix-digit (/ (cdr q
) 16))
637 (math-format-radix-digit (%
(cdr q
) 16)))))))
639 ;;; Decompose into integer and fractional parts, without depending
640 ;;; on calc-internal-prec.
641 (defun math-float-parts (a need-frac
) ; returns ( int frac fracdigs )
643 (list (math-scale-rounding (nth 1 a
) (nth 2 a
)) '(float 0 0) 0)
644 (let* ((d (math-numdigs (nth 1 a
)))
649 (let ((qr (math-idivmod (nth 1 a
) (math-scale-int 1 n
))))
650 (list (car qr
) (math-make-float (cdr qr
) (- n
)) n
)))
651 (list (math-scale-rounding (nth 1 a
) (nth 2 a
))
654 (defun math-format-radix-float (a prec
)
655 (let ((fmt (car calc-float-format
))
656 (figs (nth 1 calc-float-format
))
657 (point calc-point-char
)
660 (let* ((afigs (math-abs figs
))
661 (fp (math-float-parts a
(> afigs
0)))
662 (calc-internal-prec (+ 3 (max (nth 2 fp
)
663 (math-convert-radix-digits
666 (frac (math-round (math-mul (math-normalize (nth 1 fp
))
667 (math-radix-float-power afigs
)))))
668 (if (not (and (math-zerop frac
) (math-zerop int
) (< figs
0)))
669 (let ((math-radix-explicit-format nil
))
670 (let ((calc-group-digits nil
))
671 (setq str
(if (> afigs
0) (math-format-number frac
) ""))
672 (if (< (length str
) afigs
)
673 (setq str
(concat (make-string (- afigs
(length str
)) ?
0)
675 (if (> (length str
) afigs
)
676 (setq str
(substring str
1)
677 int
(math-add int
1))))
678 (setq str
(concat (math-format-number int
) point str
)))
679 (when calc-group-digits
680 (setq str
(math-group-float str
))))
683 (let* ((prec calc-internal-prec
)
684 (afigs (if (> figs
0)
687 (1- (math-convert-radix-digits
689 (math-numdigs (nth 1 a
)))))))))
690 (calc-internal-prec (+ 3 (math-convert-radix-digits afigs t
)))
691 (explo -
1) (vlo (math-radix-float-power explo
))
692 (exphi 1) (vhi (math-radix-float-power exphi
))
694 (setq a
(math-normalize a
))
697 (if (math-lessp-float '(float 1 0) a
)
698 (while (not (math-lessp-float a vhi
))
699 (setq explo exphi vlo vhi
700 exphi
(math-mul exphi
2)
701 vhi
(math-radix-float-power exphi
)))
702 (while (math-lessp-float a vlo
)
703 (setq exphi explo vhi vlo
704 explo
(math-mul explo
2)
705 vlo
(math-radix-float-power explo
))))
706 (while (not (eq (math-sub exphi explo
) 1))
707 (setq expmid
(math-div2 (math-add explo exphi
))
708 vmid
(math-radix-float-power expmid
))
709 (if (math-lessp-float a vmid
)
710 (setq exphi expmid vhi vmid
)
711 (setq explo expmid vlo vmid
)))
712 (setq a
(math-div-float a vlo
)))
713 (let* ((sc (math-round (math-mul a
(math-radix-float-power
715 (math-radix-explicit-format nil
))
716 (let ((calc-group-digits nil
))
717 (setq str
(math-format-number sc
))))
718 (if (> (length str
) afigs
)
719 (setq str
(substring str
0 -
1)
721 (if (and (eq fmt
'float
)
722 (math-lessp explo
(+ (if (= figs
0)
723 (1- (math-convert-radix-digits
726 calc-display-sci-high
1))
727 (math-lessp calc-display-sci-low explo
))
728 (let ((dpos (1+ explo
)))
730 (setq str
(concat "0" point
(make-string (- dpos
) ?
0)
732 ((> dpos
(length str
))
733 (setq str
(concat str
(make-string (- dpos
(length str
))
736 (setq str
(concat (substring str
0 dpos
) point
737 (substring str dpos
)))))
739 (setq eadj
(if (eq fmt
'eng
)
740 (min (math-mod explo
3) (length str
))
742 str
(concat (substring str
0 (1+ eadj
)) point
743 (substring str
(1+ eadj
)))))
744 (setq pos
(length str
))
745 (while (eq (aref str
(1- pos
)) ?
0) (setq pos
(1- pos
)))
746 (and explo
(eq (aref str
(1- pos
)) ?.
) (setq pos
(1- pos
)))
747 (setq str
(substring str
0 pos
))
748 (when calc-group-digits
749 (setq str
(math-group-float str
)))
751 (let ((estr (let ((calc-number-radix 10)
752 (calc-group-digits nil
))
753 (setq estr
(math-format-number
754 (math-sub explo eadj
))))))
755 (setq str
(if (or (memq calc-language
'(math maple
))
756 (> calc-number-radix
14))
757 (format "%s*%d.^%s" str calc-number-radix estr
)
758 (format "%se%s" str estr
)))))))
761 (defvar math-radix-digits-cache nil
)
763 (defun math-convert-radix-digits (n &optional to-dec
)
764 (let ((key (cons n
(cons to-dec calc-number-radix
))))
765 (or (cdr (assoc key math-radix-digits-cache
))
766 (let* ((calc-internal-prec 6)
767 (log (math-div (math-real-log2 calc-number-radix
)
768 '(float 332193 -
5))))
769 (cdr (car (setq math-radix-digits-cache
770 (cons (cons key
(math-ceiling (if to-dec
773 math-radix-digits-cache
))))))))
775 (defvar math-radix-float-cache-tag nil
)
777 (defun math-radix-float-power (n)
780 (or (and (eq calc-number-radix
(car math-radix-float-cache-tag
))
781 (<= calc-internal-prec
(cdr math-radix-float-cache-tag
)))
782 (setq math-radix-float-cache-tag
(cons calc-number-radix
784 math-radix-float-cache nil
))
786 (or (cdr (assoc n math-radix-float-cache
))
787 (cdr (car (setq math-radix-float-cache
790 (let ((calc-internal-prec
791 (cdr math-radix-float-cache-tag
)))
793 (math-div-float '(float 1 0)
794 (math-radix-float-power
796 (math-mul-float (math-sqr-float
797 (math-radix-float-power
802 calc-number-radix
))))))
803 math-radix-float-cache
))))))))
806 ;;; calc-bin.el ends here