1;;; calc-bin.el --- binary functions for Calc 2 3;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: David Gillespie <daveg@synaptics.com> 7;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;;; Code: 29 30;; This file is autoloaded from calc-ext.el. 31 32(require 'calc-ext) 33(require 'calc-macs) 34 35;;; b-prefix binary commands. 36 37(defun calc-and (n) 38 (interactive "P") 39 (calc-slow-wrapper 40 (calc-enter-result 2 "and" 41 (append '(calcFunc-and) 42 (calc-top-list-n 2) 43 (and n (list (prefix-numeric-value n))))))) 44 45(defun calc-or (n) 46 (interactive "P") 47 (calc-slow-wrapper 48 (calc-enter-result 2 "or" 49 (append '(calcFunc-or) 50 (calc-top-list-n 2) 51 (and n (list (prefix-numeric-value n))))))) 52 53(defun calc-xor (n) 54 (interactive "P") 55 (calc-slow-wrapper 56 (calc-enter-result 2 "xor" 57 (append '(calcFunc-xor) 58 (calc-top-list-n 2) 59 (and n (list (prefix-numeric-value n))))))) 60 61(defun calc-diff (n) 62 (interactive "P") 63 (calc-slow-wrapper 64 (calc-enter-result 2 "diff" 65 (append '(calcFunc-diff) 66 (calc-top-list-n 2) 67 (and n (list (prefix-numeric-value n))))))) 68 69(defun calc-not (n) 70 (interactive "P") 71 (calc-slow-wrapper 72 (calc-enter-result 1 "not" 73 (append '(calcFunc-not) 74 (calc-top-list-n 1) 75 (and n (list (prefix-numeric-value n))))))) 76 77(defun calc-lshift-binary (n) 78 (interactive "P") 79 (calc-slow-wrapper 80 (let ((hyp (if (calc-is-hyperbolic) 2 1))) 81 (calc-enter-result hyp "lsh" 82 (append '(calcFunc-lsh) 83 (calc-top-list-n hyp) 84 (and n (list (prefix-numeric-value n)))))))) 85 86(defun calc-rshift-binary (n) 87 (interactive "P") 88 (calc-slow-wrapper 89 (let ((hyp (if (calc-is-hyperbolic) 2 1))) 90 (calc-enter-result hyp "rsh" 91 (append '(calcFunc-rsh) 92 (calc-top-list-n hyp) 93 (and n (list (prefix-numeric-value n)))))))) 94 95(defun calc-lshift-arith (n) 96 (interactive "P") 97 (calc-slow-wrapper 98 (let ((hyp (if (calc-is-hyperbolic) 2 1))) 99 (calc-enter-result hyp "ash" 100 (append '(calcFunc-ash) 101 (calc-top-list-n hyp) 102 (and n (list (prefix-numeric-value n)))))))) 103 104(defun calc-rshift-arith (n) 105 (interactive "P") 106 (calc-slow-wrapper 107 (let ((hyp (if (calc-is-hyperbolic) 2 1))) 108 (calc-enter-result hyp "rash" 109 (append '(calcFunc-rash) 110 (calc-top-list-n hyp) 111 (and n (list (prefix-numeric-value n)))))))) 112 113(defun calc-rotate-binary (n) 114 (interactive "P") 115 (calc-slow-wrapper 116 (let ((hyp (if (calc-is-hyperbolic) 2 1))) 117 (calc-enter-result hyp "rot" 118 (append '(calcFunc-rot) 119 (calc-top-list-n hyp) 120 (and n (list (prefix-numeric-value n)))))))) 121 122(defun calc-clip (n) 123 (interactive "P") 124 (calc-slow-wrapper 125 (calc-enter-result 1 "clip" 126 (append '(calcFunc-clip) 127 (calc-top-list-n 1) 128 (and n (list (prefix-numeric-value n))))))) 129 130(defun calc-word-size (n) 131 (interactive "P") 132 (calc-wrapper 133 (or n (setq n (read-string (format "Binary word size: (default %d) " 134 calc-word-size)))) 135 (setq n (if (stringp n) 136 (if (equal n "") 137 calc-word-size 138 (if (string-match "\\`[-+]?[0-9]+\\'" n) 139 (string-to-number n) 140 (error "Expected an integer"))) 141 (prefix-numeric-value n))) 142 (or (= n calc-word-size) 143 (if (> (math-abs n) 100) 144 (calc-change-mode 'calc-word-size n calc-leading-zeros) 145 (calc-change-mode '(calc-word-size calc-previous-modulo) 146 (list n (math-power-of-2 (math-abs n))) 147 calc-leading-zeros))) 148 (if (< n 0) 149 (message "Binary word size is %d bits (2's complement)" (- n)) 150 (message "Binary word size is %d bits" n)))) 151 152 153 154 155 156;;; d-prefix mode commands. 157 158(defun calc-radix (n) 159 (interactive "NDisplay radix (2-36): ") 160 (calc-wrapper 161 (if (and (>= n 2) (<= n 36)) 162 (progn 163 (calc-change-mode 'calc-number-radix n t) 164 ;; also change global value so minibuffer sees it 165 (setq-default calc-number-radix calc-number-radix)) 166 (setq n calc-number-radix)) 167 (message "Number radix is %d" n))) 168 169(defun calc-decimal-radix () 170 (interactive) 171 (calc-radix 10)) 172 173(defun calc-binary-radix () 174 (interactive) 175 (calc-radix 2)) 176 177(defun calc-octal-radix () 178 (interactive) 179 (calc-radix 8)) 180 181(defun calc-hex-radix () 182 (interactive) 183 (calc-radix 16)) 184 185(defun calc-leading-zeros (n) 186 (interactive "P") 187 (calc-wrapper 188 (if (calc-change-mode 'calc-leading-zeros n t t) 189 (message "Zero-padding integers to %d digits (assuming radix %d)" 190 (let* ((calc-internal-prec 6)) 191 (math-compute-max-digits (math-abs calc-word-size) 192 calc-number-radix)) 193 calc-number-radix) 194 (message "Omitting leading zeros on integers")))) 195 196 197(defvar math-power-of-2-cache (list 1 2 4 8 16 32 64 128 256 512 1024)) 198(defvar math-big-power-of-2-cache nil) 199(defun math-power-of-2 (n) ; [I I] [Public] 200 (if (and (natnump n) (<= n 100)) 201 (or (nth n math-power-of-2-cache) 202 (let* ((i (length math-power-of-2-cache)) 203 (val (nth (1- i) math-power-of-2-cache))) 204 (while (<= i n) 205 (setq val (math-mul val 2) 206 math-power-of-2-cache (nconc math-power-of-2-cache 207 (list val)) 208 i (1+ i))) 209 val)) 210 (let ((found (assq n math-big-power-of-2-cache))) 211 (if found 212 (cdr found) 213 (let ((po2 (math-ipow 2 n))) 214 (setq math-big-power-of-2-cache 215 (cons (cons n po2) math-big-power-of-2-cache)) 216 po2))))) 217 218(defun math-integer-log2 (n) ; [I I] [Public] 219 (let ((i 0) 220 (p math-power-of-2-cache) 221 val) 222 (while (and p (Math-natnum-lessp (setq val (car p)) n)) 223 (setq p (cdr p) 224 i (1+ i))) 225 (if p 226 (and (equal val n) 227 i) 228 (while (Math-natnum-lessp 229 (prog1 230 (setq val (math-mul val 2)) 231 (setq math-power-of-2-cache (nconc math-power-of-2-cache 232 (list val)))) 233 n) 234 (setq i (1+ i))) 235 (and (equal val n) 236 i)))) 237 238 239 240 241;;; Bitwise operations. 242 243(defun calcFunc-and (a b &optional w) ; [I I I] [Public] 244 (cond ((Math-messy-integerp w) 245 (calcFunc-and a b (math-trunc w))) 246 ((and w (not (integerp w))) 247 (math-reject-arg w 'fixnump)) 248 ((and (integerp a) (integerp b)) 249 (math-clip (logand a b) w)) 250 ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) 251 (math-binary-modulo-args 'calcFunc-and a b w)) 252 ((not (Math-num-integerp a)) 253 (math-reject-arg a 'integerp)) 254 ((not (Math-num-integerp b)) 255 (math-reject-arg b 'integerp)) 256 (t (math-clip (cons 'bigpos 257 (math-and-bignum (math-binary-arg a w) 258 (math-binary-arg b w))) 259 w)))) 260 261(defun math-binary-arg (a w) 262 (if (not (Math-integerp a)) 263 (setq a (math-trunc a))) 264 (if (Math-integer-negp a) 265 (math-not-bignum (cdr (math-bignum-test (math-sub -1 a))) 266 (math-abs (if w (math-trunc w) calc-word-size))) 267 (cdr (Math-bignum-test a)))) 268 269(defun math-binary-modulo-args (f a b w) 270 (let (mod) 271 (if (eq (car-safe a) 'mod) 272 (progn 273 (setq mod (nth 2 a) 274 a (nth 1 a)) 275 (if (eq (car-safe b) 'mod) 276 (if (equal mod (nth 2 b)) 277 (setq b (nth 1 b)) 278 (math-reject-arg b "*Inconsistent modulos")))) 279 (setq mod (nth 2 b) 280 b (nth 1 b))) 281 (if (Math-messy-integerp mod) 282 (setq mod (math-trunc mod)) 283 (or (Math-integerp mod) 284 (math-reject-arg mod 'integerp))) 285 (let ((bits (math-integer-log2 mod))) 286 (if bits 287 (if w 288 (if (/= w bits) 289 (calc-record-why 290 "*Warning: Modulo inconsistent with word size")) 291 (setq w bits)) 292 (calc-record-why "*Warning: Modulo is not a power of 2")) 293 (math-make-mod (if b 294 (funcall f a b w) 295 (funcall f a w)) 296 mod)))) 297 298(defun math-and-bignum (a b) ; [l l l] 299 (and a b 300 (let ((qa (math-div-bignum-digit a 512)) 301 (qb (math-div-bignum-digit b 512))) 302 (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa)) 303 (math-norm-bignum (car qb))) 304 512 305 (logand (cdr qa) (cdr qb)))))) 306 307(defun calcFunc-or (a b &optional w) ; [I I I] [Public] 308 (cond ((Math-messy-integerp w) 309 (calcFunc-or a b (math-trunc w))) 310 ((and w (not (integerp w))) 311 (math-reject-arg w 'fixnump)) 312 ((and (integerp a) (integerp b)) 313 (math-clip (logior a b) w)) 314 ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) 315 (math-binary-modulo-args 'calcFunc-or a b w)) 316 ((not (Math-num-integerp a)) 317 (math-reject-arg a 'integerp)) 318 ((not (Math-num-integerp b)) 319 (math-reject-arg b 'integerp)) 320 (t (math-clip (cons 'bigpos 321 (math-or-bignum (math-binary-arg a w) 322 (math-binary-arg b w))) 323 w)))) 324 325(defun math-or-bignum (a b) ; [l l l] 326 (and (or a b) 327 (let ((qa (math-div-bignum-digit a 512)) 328 (qb (math-div-bignum-digit b 512))) 329 (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa)) 330 (math-norm-bignum (car qb))) 331 512 332 (logior (cdr qa) (cdr qb)))))) 333 334(defun calcFunc-xor (a b &optional w) ; [I I I] [Public] 335 (cond ((Math-messy-integerp w) 336 (calcFunc-xor a b (math-trunc w))) 337 ((and w (not (integerp w))) 338 (math-reject-arg w 'fixnump)) 339 ((and (integerp a) (integerp b)) 340 (math-clip (logxor a b) w)) 341 ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) 342 (math-binary-modulo-args 'calcFunc-xor a b w)) 343 ((not (Math-num-integerp a)) 344 (math-reject-arg a 'integerp)) 345 ((not (Math-num-integerp b)) 346 (math-reject-arg b 'integerp)) 347 (t (math-clip (cons 'bigpos 348 (math-xor-bignum (math-binary-arg a w) 349 (math-binary-arg b w))) 350 w)))) 351 352(defun math-xor-bignum (a b) ; [l l l] 353 (and (or a b) 354 (let ((qa (math-div-bignum-digit a 512)) 355 (qb (math-div-bignum-digit b 512))) 356 (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa)) 357 (math-norm-bignum (car qb))) 358 512 359 (logxor (cdr qa) (cdr qb)))))) 360 361(defun calcFunc-diff (a b &optional w) ; [I I I] [Public] 362 (cond ((Math-messy-integerp w) 363 (calcFunc-diff a b (math-trunc w))) 364 ((and w (not (integerp w))) 365 (math-reject-arg w 'fixnump)) 366 ((and (integerp a) (integerp b)) 367 (math-clip (logand a (lognot b)) w)) 368 ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) 369 (math-binary-modulo-args 'calcFunc-diff a b w)) 370 ((not (Math-num-integerp a)) 371 (math-reject-arg a 'integerp)) 372 ((not (Math-num-integerp b)) 373 (math-reject-arg b 'integerp)) 374 (t (math-clip (cons 'bigpos 375 (math-diff-bignum (math-binary-arg a w) 376 (math-binary-arg b w))) 377 w)))) 378 379(defun math-diff-bignum (a b) ; [l l l] 380 (and a 381 (let ((qa (math-div-bignum-digit a 512)) 382 (qb (math-div-bignum-digit b 512))) 383 (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa)) 384 (math-norm-bignum (car qb))) 385 512 386 (logand (cdr qa) (lognot (cdr qb))))))) 387 388(defun calcFunc-not (a &optional w) ; [I I] [Public] 389 (cond ((Math-messy-integerp w) 390 (calcFunc-not a (math-trunc w))) 391 ((eq (car-safe a) 'mod) 392 (math-binary-modulo-args 'calcFunc-not a nil w)) 393 ((and w (not (integerp w))) 394 (math-reject-arg w 'fixnump)) 395 ((not (Math-num-integerp a)) 396 (math-reject-arg a 'integerp)) 397 ((< (or w (setq w calc-word-size)) 0) 398 (math-clip (calcFunc-not a (- w)) w)) 399 (t (math-normalize 400 (cons 'bigpos 401 (math-not-bignum (math-binary-arg a w) 402 w)))))) 403 404(defun math-not-bignum (a w) ; [l l] 405 (let ((q (math-div-bignum-digit a 512))) 406 (if (<= w 9) 407 (list (logand (lognot (cdr q)) 408 (1- (lsh 1 w)))) 409 (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q)) 410 (- w 9)) 411 512 412 (logxor (cdr q) 511))))) 413 414(defun calcFunc-lsh (a &optional n w) ; [I I] [Public] 415 (setq a (math-trunc a) 416 n (if n (math-trunc n) 1)) 417 (if (eq (car-safe a) 'mod) 418 (math-binary-modulo-args 'calcFunc-lsh a n w) 419 (setq w (if w (math-trunc w) calc-word-size)) 420 (or (integerp w) 421 (math-reject-arg w 'fixnump)) 422 (or (Math-integerp a) 423 (math-reject-arg a 'integerp)) 424 (or (Math-integerp n) 425 (math-reject-arg n 'integerp)) 426 (if (< w 0) 427 (math-clip (calcFunc-lsh a n (- w)) w) 428 (if (Math-integer-negp a) 429 (setq a (math-clip a w))) 430 (cond ((or (Math-lessp n (- w)) 431 (Math-lessp w n)) 432 0) 433 ((< n 0) 434 (math-quotient (math-clip a w) (math-power-of-2 (- n)))) 435 (t 436 (math-clip (math-mul a (math-power-of-2 n)) w)))))) 437 438(defun calcFunc-rsh (a &optional n w) ; [I I] [Public] 439 (calcFunc-lsh a (math-neg (or n 1)) w)) 440 441(defun calcFunc-ash (a &optional n w) ; [I I] [Public] 442 (if (or (null n) 443 (not (Math-negp n))) 444 (calcFunc-lsh a n w) 445 (setq a (math-trunc a) 446 n (if n (math-trunc n) 1)) 447 (if (eq (car-safe a) 'mod) 448 (math-binary-modulo-args 'calcFunc-ash a n w) 449 (setq w (if w (math-trunc w) calc-word-size)) 450 (or (integerp w) 451 (math-reject-arg w 'fixnump)) 452 (or (Math-integerp a) 453 (math-reject-arg a 'integerp)) 454 (or (Math-integerp n) 455 (math-reject-arg n 'integerp)) 456 (if (< w 0) 457 (math-clip (calcFunc-ash a n (- w)) w) 458 (if (Math-integer-negp a) 459 (setq a (math-clip a w))) 460 (let ((two-to-sizem1 (math-power-of-2 (1- w))) 461 (sh (calcFunc-lsh a n w))) 462 (cond ((Math-natnum-lessp a two-to-sizem1) 463 sh) 464 ((Math-lessp n (- 1 w)) 465 (math-add (math-mul two-to-sizem1 2) -1)) 466 (t (let ((two-to-n (math-power-of-2 (- n)))) 467 (math-add (calcFunc-lsh (math-add two-to-n -1) 468 (+ w n) w) 469 sh))))))))) 470 471(defun calcFunc-rash (a &optional n w) ; [I I] [Public] 472 (calcFunc-ash a (math-neg (or n 1)) w)) 473 474(defun calcFunc-rot (a &optional n w) ; [I I] [Public] 475 (setq a (math-trunc a) 476 n (if n (math-trunc n) 1)) 477 (if (eq (car-safe a) 'mod) 478 (math-binary-modulo-args 'calcFunc-rot a n w) 479 (setq w (if w (math-trunc w) calc-word-size)) 480 (or (integerp w) 481 (math-reject-arg w 'fixnump)) 482 (or (Math-integerp a) 483 (math-reject-arg a 'integerp)) 484 (or (Math-integerp n) 485 (math-reject-arg n 'integerp)) 486 (if (< w 0) 487 (math-clip (calcFunc-rot a n (- w)) w) 488 (if (Math-integer-negp a) 489 (setq a (math-clip a w))) 490 (cond ((or (Math-integer-negp n) 491 (not (Math-natnum-lessp n w))) 492 (calcFunc-rot a (math-mod n w) w)) 493 (t 494 (math-add (calcFunc-lsh a (- n w) w) 495 (calcFunc-lsh a n w))))))) 496 497(defun math-clip (a &optional w) ; [I I] [Public] 498 (cond ((Math-messy-integerp w) 499 (math-clip a (math-trunc w))) 500 ((eq (car-safe a) 'mod) 501 (math-binary-modulo-args 'math-clip a nil w)) 502 ((and w (not (integerp w))) 503 (math-reject-arg w 'fixnump)) 504 ((not (Math-num-integerp a)) 505 (math-reject-arg a 'integerp)) 506 ((< (or w (setq w calc-word-size)) 0) 507 (setq a (math-clip a (- w))) 508 (if (Math-natnum-lessp a (math-power-of-2 (- -1 w))) 509 a 510 (math-sub a (math-power-of-2 (- w))))) 511 ((Math-negp a) 512 (math-normalize (cons 'bigpos (math-binary-arg a w)))) 513 ((and (integerp a) (< a 1000000)) 514 (if (>= w 20) 515 a 516 (logand a (1- (lsh 1 w))))) 517 (t 518 (math-normalize 519 (cons 'bigpos 520 (math-clip-bignum (cdr (math-bignum-test (math-trunc a))) 521 w)))))) 522 523(defalias 'calcFunc-clip 'math-clip) 524 525(defun math-clip-bignum (a w) ; [l l] 526 (let ((q (math-div-bignum-digit a 512))) 527 (if (<= w 9) 528 (list (logand (cdr q) 529 (1- (lsh 1 w)))) 530 (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q)) 531 (- w 9)) 532 512 533 (cdr q))))) 534 535(defvar math-max-digits-cache nil) 536(defun math-compute-max-digits (w r) 537 (let* ((pair (+ (* r 100000) w)) 538 (res (assq pair math-max-digits-cache))) 539 (if res 540 (cdr res) 541 (let* ((calc-command-flags nil) 542 (digs (math-ceiling (math-div w (math-real-log2 r))))) 543 (setq math-max-digits-cache (cons (cons pair digs) 544 math-max-digits-cache)) 545 digs)))) 546 547(defvar math-log2-cache (list '(2 . 1) 548 '(4 . 2) 549 '(8 . 3) 550 '(10 . (float 332193 -5)) 551 '(16 . 4) 552 '(32 . 5))) 553(defun math-real-log2 (x) ;;; calc-internal-prec must be 6 554 (let ((res (assq x math-log2-cache))) 555 (if res 556 (cdr res) 557 (let* ((calc-symbolic-mode nil) 558 (calc-display-working-message nil) 559 (log (calcFunc-log x 2))) 560 (setq math-log2-cache (cons (cons x log) math-log2-cache)) 561 log)))) 562 563(defconst math-radix-digits ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" 564 "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" 565 "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" 566 "U" "V" "W" "X" "Y" "Z"]) 567 568(defsubst math-format-radix-digit (a) ; [X D] 569 (aref math-radix-digits a)) 570 571(defun math-format-radix (a) ; [X S] 572 (if (< a calc-number-radix) 573 (if (< a 0) 574 (concat "-" (math-format-radix (- a))) 575 (math-format-radix-digit a)) 576 (let ((s "")) 577 (while (> a 0) 578 (setq s (concat (math-format-radix-digit (% a calc-number-radix)) s) 579 a (/ a calc-number-radix))) 580 s))) 581 582(defconst math-binary-digits ["000" "001" "010" "011" 583 "100" "101" "110" "111"]) 584(defun math-format-binary (a) ; [X S] 585 (if (< a 8) 586 (if (< a 0) 587 (concat "-" (math-format-binary (- a))) 588 (math-format-radix a)) 589 (let ((s "")) 590 (while (> a 7) 591 (setq s (concat (aref math-binary-digits (% a 8)) s) 592 a (/ a 8))) 593 (concat (math-format-radix a) s)))) 594 595(defun math-format-bignum-radix (a) ; [X L] 596 (cond ((null a) "0") 597 ((and (null (cdr a)) 598 (< (car a) calc-number-radix)) 599 (math-format-radix-digit (car a))) 600 (t 601 (let ((q (math-div-bignum-digit a calc-number-radix))) 602 (concat (math-format-bignum-radix (math-norm-bignum (car q))) 603 (math-format-radix-digit (cdr q))))))) 604 605(defun math-format-bignum-binary (a) ; [X L] 606 (cond ((null a) "0") 607 ((null (cdr a)) 608 (math-format-binary (car a))) 609 (t 610 (let ((q (math-div-bignum-digit a 512))) 611 (concat (math-format-bignum-binary (math-norm-bignum (car q))) 612 (aref math-binary-digits (/ (cdr q) 64)) 613 (aref math-binary-digits (% (/ (cdr q) 8) 8)) 614 (aref math-binary-digits (% (cdr q) 8))))))) 615 616(defun math-format-bignum-octal (a) ; [X L] 617 (cond ((null a) "0") 618 ((null (cdr a)) 619 (math-format-radix (car a))) 620 (t 621 (let ((q (math-div-bignum-digit a 512))) 622 (concat (math-format-bignum-octal (math-norm-bignum (car q))) 623 (math-format-radix-digit (/ (cdr q) 64)) 624 (math-format-radix-digit (% (/ (cdr q) 8) 8)) 625 (math-format-radix-digit (% (cdr q) 8))))))) 626 627(defun math-format-bignum-hex (a) ; [X L] 628 (cond ((null a) "0") 629 ((null (cdr a)) 630 (math-format-radix (car a))) 631 (t 632 (let ((q (math-div-bignum-digit a 256))) 633 (concat (math-format-bignum-hex (math-norm-bignum (car q))) 634 (math-format-radix-digit (/ (cdr q) 16)) 635 (math-format-radix-digit (% (cdr q) 16))))))) 636 637;;; Decompose into integer and fractional parts, without depending 638;;; on calc-internal-prec. 639(defun math-float-parts (a need-frac) ; returns ( int frac fracdigs ) 640 (if (>= (nth 2 a) 0) 641 (list (math-scale-rounding (nth 1 a) (nth 2 a)) '(float 0 0) 0) 642 (let* ((d (math-numdigs (nth 1 a))) 643 (n (- (nth 2 a)))) 644 (if need-frac 645 (if (>= n d) 646 (list 0 a n) 647 (let ((qr (math-idivmod (nth 1 a) (math-scale-int 1 n)))) 648 (list (car qr) (math-make-float (cdr qr) (- n)) n))) 649 (list (math-scale-rounding (nth 1 a) (nth 2 a)) 650 '(float 0 0) 0))))) 651 652(defun math-format-radix-float (a prec) 653 (let ((fmt (car calc-float-format)) 654 (figs (nth 1 calc-float-format)) 655 (point calc-point-char) 656 (str nil) 657 pos) 658 (if (eq fmt 'fix) 659 (let* ((afigs (math-abs figs)) 660 (fp (math-float-parts a (> afigs 0))) 661 (calc-internal-prec (+ 3 (max (nth 2 fp) 662 (math-convert-radix-digits 663 afigs t)))) 664 (int (car fp)) 665 (frac (math-round (math-mul (math-normalize (nth 1 fp)) 666 (math-radix-float-power afigs))))) 667 (if (not (and (math-zerop frac) (math-zerop int) (< figs 0))) 668 (let ((math-radix-explicit-format nil)) 669 (let ((calc-group-digits nil)) 670 (setq str (if (> afigs 0) (math-format-number frac) "")) 671 (if (< (length str) afigs) 672 (setq str (concat (make-string (- afigs (length str)) ?0) 673 str)) 674 (if (> (length str) afigs) 675 (setq str (substring str 1) 676 int (math-add int 1)))) 677 (setq str (concat (math-format-number int) point str))) 678 (when calc-group-digits 679 (setq str (math-group-float str)))) 680 (setq figs 0)))) 681 (or str 682 (let* ((prec calc-internal-prec) 683 (afigs (if (> figs 0) 684 figs 685 (max 1 (+ figs 686 (1- (math-convert-radix-digits 687 (max prec 688 (math-numdigs (nth 1 a))))))))) 689 (calc-internal-prec (+ 3 (math-convert-radix-digits afigs t))) 690 (explo -1) (vlo (math-radix-float-power explo)) 691 (exphi 1) (vhi (math-radix-float-power exphi)) 692 expmid vmid eadj) 693 (setq a (math-normalize a)) 694 (if (Math-zerop a) 695 (setq explo 0) 696 (if (math-lessp-float '(float 1 0) a) 697 (while (not (math-lessp-float a vhi)) 698 (setq explo exphi vlo vhi 699 exphi (math-mul exphi 2) 700 vhi (math-radix-float-power exphi))) 701 (while (math-lessp-float a vlo) 702 (setq exphi explo vhi vlo 703 explo (math-mul explo 2) 704 vlo (math-radix-float-power explo)))) 705 (while (not (eq (math-sub exphi explo) 1)) 706 (setq expmid (math-div2 (math-add explo exphi)) 707 vmid (math-radix-float-power expmid)) 708 (if (math-lessp-float a vmid) 709 (setq exphi expmid vhi vmid) 710 (setq explo expmid vlo vmid))) 711 (setq a (math-div-float a vlo))) 712 (let* ((sc (math-round (math-mul a (math-radix-float-power 713 (1- afigs))))) 714 (math-radix-explicit-format nil)) 715 (let ((calc-group-digits nil)) 716 (setq str (math-format-number sc)))) 717 (if (> (length str) afigs) 718 (setq str (substring str 0 -1) 719 explo (1+ explo))) 720 (if (and (eq fmt 'float) 721 (math-lessp explo (+ (if (= figs 0) 722 (1- (math-convert-radix-digits 723 prec)) 724 afigs) 725 calc-display-sci-high 1)) 726 (math-lessp calc-display-sci-low explo)) 727 (let ((dpos (1+ explo))) 728 (cond ((<= dpos 0) 729 (setq str (concat "0" point (make-string (- dpos) ?0) 730 str))) 731 ((> dpos (length str)) 732 (setq str (concat str (make-string (- dpos (length str)) 733 ?0) point))) 734 (t 735 (setq str (concat (substring str 0 dpos) point 736 (substring str dpos))))) 737 (setq explo nil)) 738 (setq eadj (if (eq fmt 'eng) 739 (min (math-mod explo 3) (length str)) 740 0) 741 str (concat (substring str 0 (1+ eadj)) point 742 (substring str (1+ eadj))))) 743 (setq pos (length str)) 744 (while (eq (aref str (1- pos)) ?0) (setq pos (1- pos))) 745 (and explo (eq (aref str (1- pos)) ?.) (setq pos (1- pos))) 746 (setq str (substring str 0 pos)) 747 (when calc-group-digits 748 (setq str (math-group-float str))) 749 (if explo 750 (let ((estr (let ((calc-number-radix 10) 751 (calc-group-digits nil)) 752 (math-format-number 753 (math-sub explo eadj))))) 754 (setq str (if (or (memq calc-language '(math maple)) 755 (> calc-number-radix 14)) 756 (format "%s*%d.^%s" str calc-number-radix estr) 757 (format "%se%s" str estr))))))) 758 str)) 759 760(defvar math-radix-digits-cache nil) 761 762(defun math-convert-radix-digits (n &optional to-dec) 763 (let ((key (cons n (cons to-dec calc-number-radix)))) 764 (or (cdr (assoc key math-radix-digits-cache)) 765 (let* ((calc-internal-prec 6) 766 (log (math-div (math-real-log2 calc-number-radix) 767 '(float 332193 -5)))) 768 (cdr (car (setq math-radix-digits-cache 769 (cons (cons key (math-ceiling (if to-dec 770 (math-mul n log) 771 (math-div n log)))) 772 math-radix-digits-cache)))))))) 773 774(defvar math-radix-float-cache-tag nil) 775(defvar math-radix-float-cache) 776 777(defun math-radix-float-power (n) 778 (if (eq n 0) 779 '(float 1 0) 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 783 calc-internal-prec) 784 math-radix-float-cache nil)) 785 (math-normalize 786 (or (cdr (assoc n math-radix-float-cache)) 787 (cdr (car (setq math-radix-float-cache 788 (cons (cons 789 n 790 (let ((calc-internal-prec 791 (cdr math-radix-float-cache-tag))) 792 (if (math-negp n) 793 (math-div-float '(float 1 0) 794 (math-radix-float-power 795 (math-neg n))) 796 (math-mul-float (math-sqr-float 797 (math-radix-float-power 798 (math-div2 n))) 799 (if (math-evenp n) 800 '(float 1 0) 801 (math-float 802 calc-number-radix)))))) 803 math-radix-float-cache)))))))) 804 805(provide 'calc-bin) 806 807;;; arch-tag: f6dba7bc-53b2-41ae-919c-c266ab0ca8b3 808;;; calc-bin.el ends here 809