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: Jay Belanger <belanger@truman.edu>
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 ;;; b-prefix binary commands.
39 (calc-enter-result 2 "and"
40 (append '(calcFunc-and)
42 (and n
(list (prefix-numeric-value n
)))))))
47 (calc-enter-result 2 "or"
48 (append '(calcFunc-or)
50 (and n
(list (prefix-numeric-value n
)))))))
55 (calc-enter-result 2 "xor"
56 (append '(calcFunc-xor)
58 (and n
(list (prefix-numeric-value n
)))))))
63 (calc-enter-result 2 "diff"
64 (append '(calcFunc-diff)
66 (and n
(list (prefix-numeric-value n
)))))))
71 (calc-enter-result 1 "not"
72 (append '(calcFunc-not)
74 (and n
(list (prefix-numeric-value n
)))))))
76 (defun calc-lshift-binary (n)
79 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
80 (calc-enter-result hyp
"lsh"
81 (append '(calcFunc-lsh)
83 (and n
(list (prefix-numeric-value n
))))))))
85 (defun calc-rshift-binary (n)
88 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
89 (calc-enter-result hyp
"rsh"
90 (append '(calcFunc-rsh)
92 (and n
(list (prefix-numeric-value n
))))))))
94 (defun calc-lshift-arith (n)
97 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
98 (calc-enter-result hyp
"ash"
99 (append '(calcFunc-ash)
100 (calc-top-list-n hyp
)
101 (and n
(list (prefix-numeric-value n
))))))))
103 (defun calc-rshift-arith (n)
106 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
107 (calc-enter-result hyp
"rash"
108 (append '(calcFunc-rash)
109 (calc-top-list-n hyp
)
110 (and n
(list (prefix-numeric-value n
))))))))
112 (defun calc-rotate-binary (n)
115 (let ((hyp (if (calc-is-hyperbolic) 2 1)))
116 (calc-enter-result hyp
"rot"
117 (append '(calcFunc-rot)
118 (calc-top-list-n hyp
)
119 (and n
(list (prefix-numeric-value n
))))))))
124 (calc-enter-result 1 "clip"
125 (append '(calcFunc-clip)
127 (and n
(list (prefix-numeric-value n
)))))))
129 (defun calc-word-size (n)
132 (or n
(setq n
(read-string (format "Binary word size: (default %d) "
134 (setq n
(if (stringp n
)
137 (if (string-match "\\`[-+]?[0-9]+\\'" n
)
139 (error "Expected an integer")))
140 (prefix-numeric-value n
)))
141 (or (= n calc-word-size
)
142 (if (> (math-abs n
) 100)
143 (calc-change-mode 'calc-word-size n calc-leading-zeros
)
144 (calc-change-mode '(calc-word-size calc-previous-modulo
)
145 (list n
(math-power-of-2 (math-abs n
)))
146 calc-leading-zeros
)))
148 (message "Binary word size is %d bits (2's complement)" (- n
))
149 (message "Binary word size is %d bits" n
))))
155 ;;; d-prefix mode commands.
157 (defun calc-radix (n)
158 (interactive "NDisplay radix (2-36): ")
160 (if (and (>= n
2) (<= n
36))
162 (calc-change-mode 'calc-number-radix n t
)
163 ;; also change global value so minibuffer sees it
164 (setq-default calc-number-radix calc-number-radix
))
165 (setq n calc-number-radix
))
166 (message "Number radix is %d" n
)))
168 (defun calc-decimal-radix ()
172 (defun calc-binary-radix ()
176 (defun calc-octal-radix ()
180 (defun calc-hex-radix ()
184 (defun calc-leading-zeros (n)
187 (if (calc-change-mode 'calc-leading-zeros n t t
)
188 (message "Zero-padding integers to %d digits (assuming radix %d)"
189 (let* ((calc-internal-prec 6))
190 (math-compute-max-digits (math-abs calc-word-size
)
193 (message "Omitting leading zeros on integers"))))
196 (defvar math-power-of-2-cache
(list 1 2 4 8 16 32 64 128 256 512 1024))
197 (defvar math-big-power-of-2-cache nil
)
198 (defun math-power-of-2 (n) ; [I I] [Public]
199 (if (and (natnump n
) (<= n
100))
200 (or (nth n math-power-of-2-cache
)
201 (let* ((i (length math-power-of-2-cache
))
202 (val (nth (1- i
) math-power-of-2-cache
)))
204 (setq val
(math-mul val
2)
205 math-power-of-2-cache
(nconc math-power-of-2-cache
209 (let ((found (assq n math-big-power-of-2-cache
)))
212 (let ((po2 (math-ipow 2 n
)))
213 (setq math-big-power-of-2-cache
214 (cons (cons n po2
) math-big-power-of-2-cache
))
217 (defun math-integer-log2 (n) ; [I I] [Public]
219 (p math-power-of-2-cache
)
221 (while (and p
(Math-natnum-lessp (setq val
(car p
)) n
))
227 (while (Math-natnum-lessp
229 (setq val
(math-mul val
2))
230 (setq math-power-of-2-cache
(nconc math-power-of-2-cache
240 ;;; Bitwise operations.
242 (defun calcFunc-and (a b
&optional w
) ; [I I I] [Public]
243 (cond ((Math-messy-integerp w
)
244 (calcFunc-and a b
(math-trunc w
)))
245 ((and w
(not (integerp w
)))
246 (math-reject-arg w
'fixnump
))
247 ((and (integerp a
) (integerp b
))
248 (math-clip (logand a b
) w
))
249 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
250 (math-binary-modulo-args 'calcFunc-and a b w
))
251 ((not (Math-num-integerp a
))
252 (math-reject-arg a
'integerp
))
253 ((not (Math-num-integerp b
))
254 (math-reject-arg b
'integerp
))
255 (t (math-clip (cons 'bigpos
256 (math-and-bignum (math-binary-arg a w
)
257 (math-binary-arg b w
)))
260 (defun math-binary-arg (a w
)
261 (if (not (Math-integerp a
))
262 (setq a
(math-trunc a
)))
263 (if (Math-integer-negp a
)
264 (math-not-bignum (cdr (math-bignum-test (math-sub -
1 a
)))
265 (math-abs (if w
(math-trunc w
) calc-word-size
)))
266 (cdr (Math-bignum-test a
))))
268 (defun math-binary-modulo-args (f a b w
)
270 (if (eq (car-safe a
) 'mod
)
274 (if (eq (car-safe b
) 'mod
)
275 (if (equal mod
(nth 2 b
))
277 (math-reject-arg b
"*Inconsistent modulos"))))
280 (if (Math-messy-integerp mod
)
281 (setq mod
(math-trunc mod
))
282 (or (Math-integerp mod
)
283 (math-reject-arg mod
'integerp
)))
284 (let ((bits (math-integer-log2 mod
)))
289 "*Warning: Modulo inconsistent with word size"))
291 (calc-record-why "*Warning: Modulo is not a power of 2"))
297 (defun math-and-bignum (a b
) ; [l l l]
299 (let ((qa (math-div-bignum-digit a
512))
300 (qb (math-div-bignum-digit b
512)))
301 (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa
))
302 (math-norm-bignum (car qb
)))
304 (logand (cdr qa
) (cdr qb
))))))
306 (defun calcFunc-or (a b
&optional w
) ; [I I I] [Public]
307 (cond ((Math-messy-integerp w
)
308 (calcFunc-or a b
(math-trunc w
)))
309 ((and w
(not (integerp w
)))
310 (math-reject-arg w
'fixnump
))
311 ((and (integerp a
) (integerp b
))
312 (math-clip (logior a b
) w
))
313 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
314 (math-binary-modulo-args 'calcFunc-or a b w
))
315 ((not (Math-num-integerp a
))
316 (math-reject-arg a
'integerp
))
317 ((not (Math-num-integerp b
))
318 (math-reject-arg b
'integerp
))
319 (t (math-clip (cons 'bigpos
320 (math-or-bignum (math-binary-arg a w
)
321 (math-binary-arg b w
)))
324 (defun math-or-bignum (a b
) ; [l l l]
326 (let ((qa (math-div-bignum-digit a
512))
327 (qb (math-div-bignum-digit b
512)))
328 (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa
))
329 (math-norm-bignum (car qb
)))
331 (logior (cdr qa
) (cdr qb
))))))
333 (defun calcFunc-xor (a b
&optional w
) ; [I I I] [Public]
334 (cond ((Math-messy-integerp w
)
335 (calcFunc-xor a b
(math-trunc w
)))
336 ((and w
(not (integerp w
)))
337 (math-reject-arg w
'fixnump
))
338 ((and (integerp a
) (integerp b
))
339 (math-clip (logxor a b
) w
))
340 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
341 (math-binary-modulo-args 'calcFunc-xor a b w
))
342 ((not (Math-num-integerp a
))
343 (math-reject-arg a
'integerp
))
344 ((not (Math-num-integerp b
))
345 (math-reject-arg b
'integerp
))
346 (t (math-clip (cons 'bigpos
347 (math-xor-bignum (math-binary-arg a w
)
348 (math-binary-arg b w
)))
351 (defun math-xor-bignum (a b
) ; [l l l]
353 (let ((qa (math-div-bignum-digit a
512))
354 (qb (math-div-bignum-digit b
512)))
355 (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa
))
356 (math-norm-bignum (car qb
)))
358 (logxor (cdr qa
) (cdr qb
))))))
360 (defun calcFunc-diff (a b
&optional w
) ; [I I I] [Public]
361 (cond ((Math-messy-integerp w
)
362 (calcFunc-diff a b
(math-trunc w
)))
363 ((and w
(not (integerp w
)))
364 (math-reject-arg w
'fixnump
))
365 ((and (integerp a
) (integerp b
))
366 (math-clip (logand a
(lognot b
)) w
))
367 ((or (eq (car-safe a
) 'mod
) (eq (car-safe b
) 'mod
))
368 (math-binary-modulo-args 'calcFunc-diff a b w
))
369 ((not (Math-num-integerp a
))
370 (math-reject-arg a
'integerp
))
371 ((not (Math-num-integerp b
))
372 (math-reject-arg b
'integerp
))
373 (t (math-clip (cons 'bigpos
374 (math-diff-bignum (math-binary-arg a w
)
375 (math-binary-arg b w
)))
378 (defun math-diff-bignum (a b
) ; [l l l]
380 (let ((qa (math-div-bignum-digit a
512))
381 (qb (math-div-bignum-digit b
512)))
382 (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa
))
383 (math-norm-bignum (car qb
)))
385 (logand (cdr qa
) (lognot (cdr qb
)))))))
387 (defun calcFunc-not (a &optional w
) ; [I I] [Public]
388 (cond ((Math-messy-integerp w
)
389 (calcFunc-not a
(math-trunc w
)))
390 ((eq (car-safe a
) 'mod
)
391 (math-binary-modulo-args 'calcFunc-not a nil w
))
392 ((and w
(not (integerp w
)))
393 (math-reject-arg w
'fixnump
))
394 ((not (Math-num-integerp a
))
395 (math-reject-arg a
'integerp
))
396 ((< (or w
(setq w calc-word-size
)) 0)
397 (math-clip (calcFunc-not a
(- w
)) w
))
400 (math-not-bignum (math-binary-arg a w
)
403 (defun math-not-bignum (a w
) ; [l l]
404 (let ((q (math-div-bignum-digit a
512)))
406 (list (logand (lognot (cdr q
))
408 (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q
))
411 (logxor (cdr q
) 511)))))
413 (defun calcFunc-lsh (a &optional n w
) ; [I I] [Public]
414 (setq a
(math-trunc a
)
415 n
(if n
(math-trunc n
) 1))
416 (if (eq (car-safe a
) 'mod
)
417 (math-binary-modulo-args 'calcFunc-lsh a n w
)
418 (setq w
(if w
(math-trunc w
) calc-word-size
))
420 (math-reject-arg w
'fixnump
))
421 (or (Math-integerp a
)
422 (math-reject-arg a
'integerp
))
423 (or (Math-integerp n
)
424 (math-reject-arg n
'integerp
))
426 (math-clip (calcFunc-lsh a n
(- w
)) w
)
427 (if (Math-integer-negp a
)
428 (setq a
(math-clip a w
)))
429 (cond ((or (Math-lessp n
(- w
))
433 (math-quotient (math-clip a w
) (math-power-of-2 (- n
))))
435 (math-clip (math-mul a
(math-power-of-2 n
)) w
))))))
437 (defun calcFunc-rsh (a &optional n w
) ; [I I] [Public]
438 (calcFunc-lsh a
(math-neg (or n
1)) w
))
440 (defun calcFunc-ash (a &optional n w
) ; [I I] [Public]
444 (setq a
(math-trunc a
)
445 n
(if n
(math-trunc n
) 1))
446 (if (eq (car-safe a
) 'mod
)
447 (math-binary-modulo-args 'calcFunc-ash a n w
)
448 (setq w
(if w
(math-trunc w
) calc-word-size
))
450 (math-reject-arg w
'fixnump
))
451 (or (Math-integerp a
)
452 (math-reject-arg a
'integerp
))
453 (or (Math-integerp n
)
454 (math-reject-arg n
'integerp
))
456 (math-clip (calcFunc-ash a n
(- w
)) w
)
457 (if (Math-integer-negp a
)
458 (setq a
(math-clip a w
)))
459 (let ((two-to-sizem1 (math-power-of-2 (1- w
)))
460 (sh (calcFunc-lsh a n w
)))
461 (cond ((Math-natnum-lessp a two-to-sizem1
)
463 ((Math-lessp n
(- 1 w
))
464 (math-add (math-mul two-to-sizem1
2) -
1))
465 (t (let ((two-to-n (math-power-of-2 (- n
))))
466 (math-add (calcFunc-lsh (math-add two-to-n -
1)
470 (defun calcFunc-rash (a &optional n w
) ; [I I] [Public]
471 (calcFunc-ash a
(math-neg (or n
1)) w
))
473 (defun calcFunc-rot (a &optional n w
) ; [I I] [Public]
474 (setq a
(math-trunc a
)
475 n
(if n
(math-trunc n
) 1))
476 (if (eq (car-safe a
) 'mod
)
477 (math-binary-modulo-args 'calcFunc-rot a n w
)
478 (setq w
(if w
(math-trunc w
) calc-word-size
))
480 (math-reject-arg w
'fixnump
))
481 (or (Math-integerp a
)
482 (math-reject-arg a
'integerp
))
483 (or (Math-integerp n
)
484 (math-reject-arg n
'integerp
))
486 (math-clip (calcFunc-rot a n
(- w
)) w
)
487 (if (Math-integer-negp a
)
488 (setq a
(math-clip a w
)))
489 (cond ((or (Math-integer-negp n
)
490 (not (Math-natnum-lessp n w
)))
491 (calcFunc-rot a
(math-mod n w
) w
))
493 (math-add (calcFunc-lsh a
(- n w
) w
)
494 (calcFunc-lsh a n w
)))))))
496 (defun math-clip (a &optional w
) ; [I I] [Public]
497 (cond ((Math-messy-integerp w
)
498 (math-clip a
(math-trunc w
)))
499 ((eq (car-safe a
) 'mod
)
500 (math-binary-modulo-args 'math-clip a nil w
))
501 ((and w
(not (integerp w
)))
502 (math-reject-arg w
'fixnump
))
503 ((not (Math-num-integerp a
))
504 (math-reject-arg a
'integerp
))
505 ((< (or w
(setq w calc-word-size
)) 0)
506 (setq a
(math-clip a
(- w
)))
507 (if (Math-natnum-lessp a
(math-power-of-2 (- -
1 w
)))
509 (math-sub a
(math-power-of-2 (- w
)))))
511 (math-normalize (cons 'bigpos
(math-binary-arg a w
))))
512 ((and (integerp a
) (< a
1000000))
515 (logand a
(1- (lsh 1 w
)))))
519 (math-clip-bignum (cdr (math-bignum-test (math-trunc a
)))
522 (defalias 'calcFunc-clip
'math-clip
)
524 (defun math-clip-bignum (a w
) ; [l l]
525 (let ((q (math-div-bignum-digit a
512)))
527 (list (logand (cdr q
)
529 (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q
))
534 (defvar math-max-digits-cache nil
)
535 (defun math-compute-max-digits (w r
)
536 (let* ((pair (+ (* r
100000) w
))
537 (res (assq pair math-max-digits-cache
)))
540 (let* ((calc-command-flags nil
)
541 (digs (math-ceiling (math-div w
(math-real-log2 r
)))))
542 (setq math-max-digits-cache
(cons (cons pair digs
)
543 math-max-digits-cache
))
546 (defvar math-log2-cache
(list '(2 .
1)
549 '(10 .
(float 332193 -
5))
552 (defun math-real-log2 (x) ;;; calc-internal-prec must be 6
553 (let ((res (assq x math-log2-cache
)))
556 (let* ((calc-symbolic-mode nil
)
557 (calc-display-working-message nil
)
558 (log (calcFunc-log x
2)))
559 (setq math-log2-cache
(cons (cons x log
) math-log2-cache
))
562 (defconst math-radix-digits
["0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
563 "A" "B" "C" "D" "E" "F" "G" "H" "I" "J"
564 "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T"
565 "U" "V" "W" "X" "Y" "Z"])
567 (defsubst math-format-radix-digit
(a) ; [X D]
568 (aref math-radix-digits a
))
570 (defun math-format-radix (a) ; [X S]
571 (if (< a calc-number-radix
)
573 (concat "-" (math-format-radix (- a
)))
574 (math-format-radix-digit a
))
577 (setq s
(concat (math-format-radix-digit (% a calc-number-radix
)) s
)
578 a
(/ a calc-number-radix
)))
581 (defconst math-binary-digits
["000" "001" "010" "011"
582 "100" "101" "110" "111"])
583 (defun math-format-binary (a) ; [X S]
586 (concat "-" (math-format-binary (- a
)))
587 (math-format-radix a
))
590 (setq s
(concat (aref math-binary-digits
(% a
8)) s
)
592 (concat (math-format-radix a
) s
))))
594 (defun math-format-bignum-radix (a) ; [X L]
597 (< (car a
) calc-number-radix
))
598 (math-format-radix-digit (car a
)))
600 (let ((q (math-div-bignum-digit a calc-number-radix
)))
601 (concat (math-format-bignum-radix (math-norm-bignum (car q
)))
602 (math-format-radix-digit (cdr q
)))))))
604 (defun math-format-bignum-binary (a) ; [X L]
607 (math-format-binary (car a
)))
609 (let ((q (math-div-bignum-digit a
512)))
610 (concat (math-format-bignum-binary (math-norm-bignum (car q
)))
611 (aref math-binary-digits
(/ (cdr q
) 64))
612 (aref math-binary-digits
(%
(/ (cdr q
) 8) 8))
613 (aref math-binary-digits
(%
(cdr q
) 8)))))))
615 (defun math-format-bignum-octal (a) ; [X L]
618 (math-format-radix (car a
)))
620 (let ((q (math-div-bignum-digit a
512)))
621 (concat (math-format-bignum-octal (math-norm-bignum (car q
)))
622 (math-format-radix-digit (/ (cdr q
) 64))
623 (math-format-radix-digit (%
(/ (cdr q
) 8) 8))
624 (math-format-radix-digit (%
(cdr q
) 8)))))))
626 (defun math-format-bignum-hex (a) ; [X L]
629 (math-format-radix (car a
)))
631 (let ((q (math-div-bignum-digit a
256)))
632 (concat (math-format-bignum-hex (math-norm-bignum (car q
)))
633 (math-format-radix-digit (/ (cdr q
) 16))
634 (math-format-radix-digit (%
(cdr q
) 16)))))))
636 ;;; Decompose into integer and fractional parts, without depending
637 ;;; on calc-internal-prec.
638 (defun math-float-parts (a need-frac
) ; returns ( int frac fracdigs )
640 (list (math-scale-rounding (nth 1 a
) (nth 2 a
)) '(float 0 0) 0)
641 (let* ((d (math-numdigs (nth 1 a
)))
646 (let ((qr (math-idivmod (nth 1 a
) (math-scale-int 1 n
))))
647 (list (car qr
) (math-make-float (cdr qr
) (- n
)) n
)))
648 (list (math-scale-rounding (nth 1 a
) (nth 2 a
))
651 (defun math-format-radix-float (a prec
)
652 (let ((fmt (car calc-float-format
))
653 (figs (nth 1 calc-float-format
))
654 (point calc-point-char
)
658 (let* ((afigs (math-abs figs
))
659 (fp (math-float-parts a
(> afigs
0)))
660 (calc-internal-prec (+ 3 (max (nth 2 fp
)
661 (math-convert-radix-digits
664 (frac (math-round (math-mul (math-normalize (nth 1 fp
))
665 (math-radix-float-power afigs
)))))
666 (if (not (and (math-zerop frac
) (math-zerop int
) (< figs
0)))
667 (let ((math-radix-explicit-format nil
))
668 (let ((calc-group-digits nil
))
669 (setq str
(if (> afigs
0) (math-format-number frac
) ""))
670 (if (< (length str
) afigs
)
671 (setq str
(concat (make-string (- afigs
(length str
)) ?
0)
673 (if (> (length str
) afigs
)
674 (setq str
(substring str
1)
675 int
(math-add int
1))))
676 (setq str
(concat (math-format-number int
) point str
)))
677 (when calc-group-digits
678 (setq str
(math-group-float str
))))
681 (let* ((prec calc-internal-prec
)
682 (afigs (if (> figs
0)
685 (1- (math-convert-radix-digits
687 (math-numdigs (nth 1 a
)))))))))
688 (calc-internal-prec (+ 3 (math-convert-radix-digits afigs t
)))
689 (explo -
1) (vlo (math-radix-float-power explo
))
690 (exphi 1) (vhi (math-radix-float-power exphi
))
692 (setq a
(math-normalize a
))
695 (if (math-lessp-float '(float 1 0) a
)
696 (while (not (math-lessp-float a vhi
))
697 (setq explo exphi vlo vhi
698 exphi
(math-mul exphi
2)
699 vhi
(math-radix-float-power exphi
)))
700 (while (math-lessp-float a vlo
)
701 (setq exphi explo vhi vlo
702 explo
(math-mul explo
2)
703 vlo
(math-radix-float-power explo
))))
704 (while (not (eq (math-sub exphi explo
) 1))
705 (setq expmid
(math-div2 (math-add explo exphi
))
706 vmid
(math-radix-float-power expmid
))
707 (if (math-lessp-float a vmid
)
708 (setq exphi expmid vhi vmid
)
709 (setq explo expmid vlo vmid
)))
710 (setq a
(math-div-float a vlo
)))
711 (let* ((sc (math-round (math-mul a
(math-radix-float-power
713 (math-radix-explicit-format nil
))
714 (let ((calc-group-digits nil
))
715 (setq str
(math-format-number sc
))))
716 (if (> (length str
) afigs
)
717 (setq str
(substring str
0 -
1)
719 (if (and (eq fmt
'float
)
720 (math-lessp explo
(+ (if (= figs
0)
721 (1- (math-convert-radix-digits
724 calc-display-sci-high
1))
725 (math-lessp calc-display-sci-low explo
))
726 (let ((dpos (1+ explo
)))
728 (setq str
(concat "0" point
(make-string (- dpos
) ?
0)
730 ((> dpos
(length str
))
731 (setq str
(concat str
(make-string (- dpos
(length str
))
734 (setq str
(concat (substring str
0 dpos
) point
735 (substring str dpos
)))))
737 (setq eadj
(if (eq fmt
'eng
)
738 (min (math-mod explo
3) (length str
))
740 str
(concat (substring str
0 (1+ eadj
)) point
741 (substring str
(1+ eadj
)))))
742 (setq pos
(length str
))
743 (while (eq (aref str
(1- pos
)) ?
0) (setq pos
(1- pos
)))
744 (and explo
(eq (aref str
(1- pos
)) ?.
) (setq pos
(1- pos
)))
745 (setq str
(substring str
0 pos
))
746 (when calc-group-digits
747 (setq str
(math-group-float str
)))
749 (let ((estr (let ((calc-number-radix 10)
750 (calc-group-digits nil
))
752 (math-sub explo eadj
)))))
753 (setq str
(if (or (memq calc-language
'(math maple
))
754 (> calc-number-radix
14))
755 (format "%s*%d.^%s" str calc-number-radix estr
)
756 (format "%se%s" str estr
)))))))
759 (defvar math-radix-digits-cache nil
)
761 (defun math-convert-radix-digits (n &optional to-dec
)
762 (let ((key (cons n
(cons to-dec calc-number-radix
))))
763 (or (cdr (assoc key math-radix-digits-cache
))
764 (let* ((calc-internal-prec 6)
765 (log (math-div (math-real-log2 calc-number-radix
)
766 '(float 332193 -
5))))
767 (cdr (car (setq math-radix-digits-cache
768 (cons (cons key
(math-ceiling (if to-dec
771 math-radix-digits-cache
))))))))
773 (defvar math-radix-float-cache-tag nil
)
774 (defvar math-radix-float-cache
)
776 (defun math-radix-float-power (n)
779 (or (and (eq calc-number-radix
(car math-radix-float-cache-tag
))
780 (<= calc-internal-prec
(cdr math-radix-float-cache-tag
)))
781 (setq math-radix-float-cache-tag
(cons calc-number-radix
783 math-radix-float-cache nil
))
785 (or (cdr (assoc n math-radix-float-cache
))
786 (cdr (car (setq math-radix-float-cache
789 (let ((calc-internal-prec
790 (cdr math-radix-float-cache-tag
)))
792 (math-div-float '(float 1 0)
793 (math-radix-float-power
795 (math-mul-float (math-sqr-float
796 (math-radix-float-power
801 calc-number-radix
))))))
802 math-radix-float-cache
))))))))
806 ;;; arch-tag: f6dba7bc-53b2-41ae-919c-c266ab0ca8b3
807 ;;; calc-bin.el ends here