cgit.sxemacs.org Git - packages/blob - xemacs-packages/calc/calc-bin.el

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