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

   1 ;; Calculator for GNU Emacs, part II [calc-yank.el]
   2 ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
   3 ;; Written by Dave Gillespie, daveg@synaptics.com.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is distributed in the hope that it will be useful,
   8 ;; but WITHOUT ANY WARRANTY.  No author or distributor
   9 ;; accepts responsibility to anyone for the consequences of using it
  10 ;; or for whether it serves any particular purpose or works at all,
  11 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12 ;; License for full details.
  13
  14 ;; Everyone is granted permission to copy, modify and redistribute
  15 ;; GNU Emacs, but only under the conditions described in the
  16 ;; GNU Emacs General Public License.   A copy of this license is
  17 ;; supposed to have been given to you along with GNU Emacs so you
  18 ;; can know your rights and responsibilities.  It should be in a
  19 ;; file named COPYING.  Among other things, the copyright notice
  20 ;; and this notice must be preserved on all copies.
  21
  22
  23
  24 ;; This file is autoloaded from calc-ext.el.
  25 (require 'calc-ext)
  26
  27 (require 'calc-macs)
  28
  29 (defun calc-Need-calc-yank () nil)
  30
  31
  32 ;;; Kill ring commands.
  33
  34 (defun calc-kill (nn &optional no-delete)
  35   (interactive "P")
  36   (if (eq major-mode 'calc-mode)
  37       (calc-wrapper
  38        (calc-force-refresh)
  39        (calc-set-command-flag 'no-align)
  40        (let ((num (max (calc-locate-cursor-element (point)) 1))
  41              (n (prefix-numeric-value nn)))
  42          (if (< n 0)
  43              (progn
  44                (if (eobp)
  45                    (setq num (1- num)))
  46                (setq num (- num n)
  47                      n (- n))))
  48          (let ((stuff (calc-top-list n (- num n -1))))
  49            (calc-cursor-stack-index num)
  50            (let ((first (point)))
  51              (calc-cursor-stack-index (- num n))
  52              (if (null nn)
  53                  (backward-char 1))   ; don't include newline for raw C-k
  54              (copy-region-as-kill first (point))
  55              (if (not no-delete)
  56                  (calc-pop-stack n (- num n -1))))
  57            (setq calc-last-kill (cons (car kill-ring) stuff)))))
  58     (kill-line nn))
  59 )
  60
  61 (defun calc-force-refresh ()
  62   (if (or calc-executing-macro calc-display-dirty)
  63       (let ((calc-executing-macro nil))
  64         (calc-refresh)))
  65 )
  66
  67 (defun calc-locate-cursor-element (pt)
  68   (save-excursion
  69     (goto-char (point-max))
  70     (calc-locate-cursor-scan (- calc-stack-top) calc-stack pt))
  71 )
  72
  73 (defun calc-locate-cursor-scan (n stack pt)
  74   (if (or (<= (point) pt)
  75           (null stack))
  76       n
  77     (forward-line (- (nth 1 (car stack))))
  78     (calc-locate-cursor-scan (1+ n) (cdr stack) pt))
  79 )
  80
  81 (defun calc-kill-region (top bot &optional no-delete)
  82   (interactive "r")
  83   (if (eq major-mode 'calc-mode)
  84       (calc-wrapper
  85        (calc-force-refresh)
  86        (calc-set-command-flag 'no-align)
  87        (let* ((top-num (calc-locate-cursor-element top))
  88               (bot-num (calc-locate-cursor-element (1- bot)))
  89               (num (- top-num bot-num -1)))
  90          (copy-region-as-kill top bot)
  91          (setq calc-last-kill (cons (car kill-ring)
  92                                     (calc-top-list num bot-num)))
  93          (if (not no-delete)
  94              (calc-pop-stack num bot-num))))
  95     (if no-delete
  96         (copy-region-as-kill top bot)
  97       (kill-region top bot)))
  98 )
  99
 100 (defun calc-copy-as-kill (n)
 101   (interactive "P")
 102   (calc-kill n t)
 103 )
 104
 105 (defun calc-copy-region-as-kill (top bot)
 106   (interactive "r")
 107   (calc-kill-region top bot t)
 108 )
 109
 110 ;;; This function uses calc-last-kill if possible to get an exact result,
 111 ;;; otherwise it just parses the yanked string.
 112 ;;; Modified to use Emacs 19 extended concept of kill-ring. -- daveg 12/15/96
 113 (defun calc-yank ()
 114   (interactive)
 115   (calc-wrapper
 116    (calc-pop-push-record-list
 117     0 "yank"
 118     (let ((thing (if (fboundp 'current-kill)
 119                      (current-kill 0 t)
 120                    (car kill-ring-yank-pointer))))
 121       (if (eq (car-safe calc-last-kill) thing)
 122           (cdr calc-last-kill)
 123         (if (stringp thing)
 124             (let ((val (math-read-exprs (calc-clean-newlines thing))))
 125               (if (eq (car-safe val) 'error)
 126                   (progn
 127                     (setq val (math-read-exprs thing))
 128                     (if (eq (car-safe val) 'error)
 129                         (error "Bad format in yanked data")
 130                       val))
 131                 val)))))))
 132 )
 133
 134 (defun calc-clean-newlines (s)
 135   (cond
 136
 137    ;; Omit leading/trailing whitespace
 138    ((or (string-match "\\`[ \n\r]+\\([^\001]*\\)\\'" s)
 139         (string-match "\\`\\([^\001]*\\)[ \n\r]+\\'" s))
 140     (calc-clean-newlines (math-match-substring s 1)))
 141
 142    ;; Convert newlines to commas
 143    ((string-match "\\`\\(.*\\)[\n\r]+\\([^\001]*\\)\\'" s)
 144     (calc-clean-newlines (concat (math-match-substring s 1) ","
 145                                  (math-match-substring s 2))))
 146
 147    (t s))
 148 )
 149
 150
 151 (defun calc-do-grab-region (top bot arg)
 152   (and (memq major-mode '(calc-mode calc-trail-mode))
 153        (error "This command works only in a regular text buffer."))
 154   (let* ((from-buffer (current-buffer))
 155          (calc-was-started (get-buffer-window "*Calculator*"))
 156          (single nil)
 157          data vals pos)
 158     (if arg
 159         (if (consp arg)
 160             (setq single t)
 161           (setq arg (prefix-numeric-value arg))
 162           (if (= arg 0)
 163               (save-excursion
 164                 (beginning-of-line)
 165                 (setq top (point))
 166                 (end-of-line)
 167                 (setq bot (point)))
 168             (save-excursion
 169               (setq top (point))
 170               (forward-line arg)
 171               (if (> arg 0)
 172                   (setq bot (point))
 173                 (setq bot top
 174                       top (point)))))))
 175     (setq data (buffer-substring top bot))
 176     (calc)
 177     (if single
 178         (setq vals (math-read-expr data))
 179       (setq vals (math-read-expr (concat "[" data "]")))
 180       (and (eq (car-safe vals) 'vec)
 181            (= (length vals) 2)
 182            (eq (car-safe (nth 1 vals)) 'vec)
 183            (setq vals (nth 1 vals))))
 184     (if (eq (car-safe vals) 'error)
 185         (progn
 186           (if calc-was-started
 187               (pop-to-buffer from-buffer)
 188             (calc-quit t)
 189             (switch-to-buffer from-buffer))
 190           (goto-char top)
 191           (forward-char (+ (nth 1 vals) (if single 0 1)))
 192           (error (nth 2 vals))))
 193     (calc-slow-wrapper
 194      (calc-enter-result 0 "grab" vals)))
 195 )
 196
 197
 198 (defun calc-do-grab-rectangle (top bot arg &optional reduce)
 199   (and (memq major-mode '(calc-mode calc-trail-mode))
 200        (error "This command works only in a regular text buffer."))
 201   (let* ((col1 (save-excursion (goto-char top) (current-column)))
 202          (col2 (save-excursion (goto-char bot) (current-column)))
 203          (from-buffer (current-buffer))
 204          (calc-was-started (get-buffer-window "*Calculator*"))
 205          data mat vals lnum pt pos)
 206     (if (= col1 col2)
 207         (save-excursion
 208           (or (= col1 0)
 209               (error "Point and mark must be at beginning of line, or define a rectangle"))
 210           (goto-char top)
 211           (while (< (point) bot)
 212             (setq pt (point))
 213             (forward-line 1)
 214             (setq data (cons (buffer-substring pt (1- (point))) data)))
 215           (setq data (nreverse data)))
 216       (setq data (extract-rectangle top bot)))
 217     (calc)
 218     (setq mat (list 'vec)
 219           lnum 0)
 220     (and arg
 221          (setq arg (if (consp arg) 0 (prefix-numeric-value arg))))
 222     (while data
 223       (if (natnump arg)
 224           (progn
 225             (if (= arg 0)
 226                 (setq arg 1000000))
 227             (setq pos 0
 228                   vals (list 'vec))
 229             (let ((w (length (car data)))
 230                   j v)
 231               (while (< pos w)
 232                 (setq j (+ pos arg)
 233                       v (if (>= j w)
 234                             (math-read-expr (substring (car data) pos))
 235                           (math-read-expr (substring (car data) pos j))))
 236                 (if (eq (car-safe v) 'error)
 237                     (setq vals v w 0)
 238                   (setq vals (nconc vals (list v))
 239                         pos j)))))
 240         (if (string-match "\\` *-?[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]? *\\'"
 241                           (car data))
 242             (setq vals (list 'vec (string-to-int (car data))))
 243           (if (and (null arg)
 244                    (string-match "[[{][^][{}]*[]}]" (car data)))
 245               (setq pos (match-beginning 0)
 246                     vals (math-read-expr (math-match-substring (car data) 0)))
 247             (let ((s (if (string-match
 248                           "\\`\\([0-9]+:[ \t]\\)?\\(.*[^, \t]\\)[, \t]*\\'"
 249                           (car data))
 250                          (math-match-substring (car data) 2)
 251                        (car data))))
 252               (setq pos -1
 253                     vals (math-read-expr (concat "[" s "]")))
 254               (if (eq (car-safe vals) 'error)
 255                   (let ((v2 (math-read-expr s)))
 256                     (or (eq (car-safe v2) 'error)
 257                         (setq vals (list 'vec v2)))))))))
 258       (if (eq (car-safe vals) 'error)
 259           (progn
 260             (if calc-was-started
 261                 (pop-to-buffer from-buffer)
 262               (calc-quit t)
 263               (switch-to-buffer from-buffer))
 264             (goto-char top)
 265             (forward-line lnum)
 266             (forward-char (+ (nth 1 vals) (min col1 col2) pos))
 267             (error (nth 2 vals))))
 268       (or (equal vals '(vec))
 269           (setq mat (cons vals mat)))
 270       (setq data (cdr data)
 271             lnum (1+ lnum)))
 272     (calc-slow-wrapper
 273      (if reduce
 274          (calc-enter-result 0 "grb+" (list reduce '(var add var-add)
 275                                            (nreverse mat)))
 276        (calc-enter-result 0 "grab" (nreverse mat)))))
 277 )
 278
 279
 280 (defun calc-copy-to-buffer (nn)
 281   "Copy the top of stack into an editing buffer."
 282   (interactive "P")
 283   (let ((thebuf (and (not (memq major-mode '(calc-mode calc-trail-mode)))
 284                      (current-buffer)))
 285         (movept nil)
 286         oldbuf newbuf)
 287     (calc-wrapper
 288      (save-excursion
 289        (calc-force-refresh)
 290        (let ((n (prefix-numeric-value nn))
 291              (eat-lnums calc-line-numbering)
 292              (big-offset (if (eq calc-language 'big) 1 0))
 293              top bot)
 294          (setq oldbuf (current-buffer)
 295                newbuf (or thebuf
 296                           (calc-find-writable-buffer (buffer-list) 0)
 297                           (calc-find-writable-buffer (buffer-list) 1)
 298                           (error "No other buffer")))
 299          (cond ((and (or (null nn)
 300                          (consp nn))
 301                      (= (calc-substack-height 0)
 302                         (- (1- (calc-substack-height 1)) big-offset)))
 303                 (calc-cursor-stack-index 1)
 304                 (if (looking-at
 305                      (if calc-line-numbering "[0-9]+: *[^ \n]" " *[^ \n]"))
 306                     (goto-char (1- (match-end 0))))
 307                 (setq eat-lnums nil
 308                       top (point))
 309                 (calc-cursor-stack-index 0)
 310                 (setq bot (- (1- (point)) big-offset)))
 311                ((> n 0)
 312                 (calc-cursor-stack-index n)
 313                 (setq top (point))
 314                 (calc-cursor-stack-index 0)
 315                 (setq bot (- (point) big-offset)))
 316                ((< n 0)
 317                 (calc-cursor-stack-index (- n))
 318                 (setq top (point))
 319                 (calc-cursor-stack-index (1- (- n)))
 320                 (setq bot (point)))
 321                (t
 322                 (goto-char (point-min))
 323                 (forward-line 1)
 324                 (setq top (point))
 325                 (calc-cursor-stack-index 0)
 326                 (setq bot (point))))
 327          (save-excursion
 328            (set-buffer newbuf)
 329            (if (consp nn)
 330                (kill-region (region-beginning) (region-end)))
 331            (push-mark (point) t)
 332            (if (and overwrite-mode (not (consp nn)))
 333                (calc-overwrite-string (save-excursion
 334                                         (set-buffer oldbuf)
 335                                         (buffer-substring top bot))
 336                                       eat-lnums)
 337              (or (bolp) (setq eat-lnums nil))
 338              (insert-buffer-substring oldbuf top bot)
 339              (and eat-lnums
 340                   (let ((n 1))
 341                     (while (and (> (point) (mark))
 342                                 (progn
 343                                   (forward-line -1)
 344                                   (>= (point) (mark))))
 345                       (delete-char 4)
 346                       (setq n (1+ n)))
 347                     (forward-line n))))
 348            (if thebuf (setq movept (point)))
 349            (if (get-buffer-window (current-buffer))
 350                (set-window-point (get-buffer-window (current-buffer))
 351                                  (point)))))))
 352     (if movept (goto-char movept))
 353     (and (consp nn)
 354          (not thebuf)
 355          (progn
 356            (calc-quit t)
 357            (switch-to-buffer newbuf))))
 358 )
 359
 360 (defun calc-overwrite-string (str eat-lnums)
 361   (if (string-match "\n\\'" str)
 362       (setq str (substring str 0 -1)))
 363   (if eat-lnums
 364       (setq str (substring str 4)))
 365   (if (and (string-match "\\`[-+]?[0-9.]+\\(e-?[0-9]+\\)?\\'" str)
 366            (looking-at "[-+]?[0-9.]+\\(e-?[0-9]+\\)?"))
 367       (progn
 368         (delete-region (point) (match-end 0))
 369         (insert str))
 370     (let ((i 0))
 371       (while (< i (length str))
 372         (if (= (setq last-command-char (aref str i)) ?\n)
 373             (or (= i (1- (length str)))
 374                 (let ((pt (point)))
 375                   (end-of-line)
 376                   (delete-region pt (point))
 377                   (if (eobp)
 378                       (insert "\n")
 379                     (forward-char 1))
 380                   (if eat-lnums (setq i (+ i 4)))))
 381           (self-insert-command 1))
 382         (setq i (1+ i)))))
 383 )
 384
 385 ;;; First, require that buffer is visible and does not begin with "*"
 386 ;;; Second, require only that it not begin with "*Calc"
 387 (defun calc-find-writable-buffer (buf mode)
 388   (and buf
 389        (if (or (string-match "\\`\\( .*\\|\\*Calc.*\\)"
 390                              (buffer-name (car buf)))
 391                (and (= mode 0)
 392                     (or (string-match "\\`\\*.*" (buffer-name (car buf)))
 393                         (not (get-buffer-window (car buf))))))
 394            (calc-find-writable-buffer (cdr buf) mode)
 395          (car buf)))
 396 )
 397
 398
 399 (defun calc-edit (n)
 400   (interactive "p")
 401   (calc-slow-wrapper
 402    (if (eq n 0)
 403        (setq n (calc-stack-size)))
 404    (let* ((flag nil)
 405           (allow-ret (> n 1))
 406           (list (math-showing-full-precision
 407                  (mapcar (if (> n 1)
 408                              (function (lambda (x)
 409                                          (math-format-flat-expr x 0)))
 410                            (function
 411                             (lambda (x)
 412                               (if (math-vectorp x) (setq allow-ret t))
 413                               (math-format-nice-expr x (frame-width)))))
 414                          (if (> n 0)
 415                              (calc-top-list n)
 416                            (calc-top-list 1 (- n)))))))
 417      (calc-edit-mode (list 'calc-finish-stack-edit (or flag n)) allow-ret)
 418      (while list
 419        (insert (car list) "\n")
 420        (setq list (cdr list)))))
 421   (calc-show-edit-buffer)
 422 )
 423
 424 (defun calc-alg-edit (str)
 425   (calc-edit-mode '(calc-finish-stack-edit 0))
 426   (calc-show-edit-buffer)
 427   (insert str "\n")
 428   (backward-char 1)
 429   (calc-set-command-flag 'do-edit)
 430 )
 431
 432 (defvar calc-edit-mode-map nil "Keymap for use by the calc-edit command.")
 433 (if calc-edit-mode-map
 434     ()
 435   (setq calc-edit-mode-map (make-sparse-keymap))
 436   (define-key calc-edit-mode-map "\n" 'calc-edit-finish)
 437   (define-key calc-edit-mode-map "\r" 'calc-edit-return)
 438   (define-key calc-edit-mode-map "\C-c\C-c" 'calc-edit-finish)
 439 )
 440
 441 (defun calc-edit-mode (&optional handler allow-ret title)
 442   "Calculator editing mode.  Press RET, LFD, or C-c C-c to finish.
 443 To cancel the edit, simply kill the *Calc Edit* buffer."
 444   (interactive)
 445   (or handler
 446       (error "This command can be used only indirectly through calc-edit."))
 447   (let ((oldbuf (current-buffer))
 448         (buf (get-buffer-create "*Calc Edit*")))
 449     (set-buffer buf)
 450     (kill-all-local-variables)
 451     (use-local-map calc-edit-mode-map)
 452     (setq buffer-read-only nil)
 453     (setq truncate-lines nil)
 454     (setq major-mode 'calc-edit-mode)
 455     (setq mode-name "Calc Edit")
 456     (run-hooks 'calc-edit-mode-hook)
 457     (make-local-variable 'calc-original-buffer)
 458     (setq calc-original-buffer oldbuf)
 459     (make-local-variable 'calc-return-buffer)
 460     (setq calc-return-buffer oldbuf)
 461     (make-local-variable 'calc-one-window)
 462     (setq calc-one-window (and (one-window-p t) pop-up-windows))
 463     (make-local-variable 'calc-edit-handler)
 464     (setq calc-edit-handler handler)
 465     (make-local-variable 'calc-restore-trail)
 466     (setq calc-restore-trail (get-buffer-window (calc-trail-buffer)))
 467     (make-local-variable 'calc-allow-ret)
 468     (setq calc-allow-ret allow-ret)
 469     (erase-buffer)
 470     (insert (or title title "Calc Edit Mode")
 471             ".  Press "
 472             (if (eq (lookup-key (current-global-map) "\e#") 'calc-dispatch)
 473                 "M-# M-# or C-c C-c"
 474               (if allow-ret "C-c C-c" "RET"))
 475             " to finish, "
 476             (if (eq (lookup-key (current-global-map) "\e#") 'calc-dispatch)
 477                 "M-# x"
 478               "C-x k RET")
 479             " to cancel.\n"))
 480 )
 481 (put 'calc-edit-mode 'mode-class 'special)
 482
 483 (defun calc-show-edit-buffer ()
 484   (let ((buf (current-buffer)))
 485     (if (and (one-window-p t) pop-up-windows)
 486         (pop-to-buffer (get-buffer-create "*Calc Edit*"))
 487       (and calc-embedded-info (get-buffer-window (aref calc-embedded-info 1))
 488            (select-window (get-buffer-window (aref calc-embedded-info 1))))
 489       (switch-to-buffer (get-buffer-create "*Calc Edit*")))
 490     (setq calc-return-buffer buf)
 491     (if (and (< (window-width) (frame-width))
 492              calc-display-trail)
 493         (let ((win (get-buffer-window (calc-trail-buffer))))
 494           (if win
 495               (delete-window win))))
 496     (set-buffer-modified-p nil)
 497     (goto-char (point-min))
 498     (forward-line 1))
 499 )
 500
 501 (defun calc-edit-return ()
 502   (interactive)
 503   (if (and (boundp 'calc-allow-ret) calc-allow-ret)
 504       (newline)
 505     (calc-edit-finish))
 506 )
 507
 508 (defun calc-edit-finish (&optional keep)
 509   "Finish calc-edit mode.  Parse buffer contents and push them on the stack."
 510   (interactive "P")
 511   (message "Working...")
 512   (or (and (boundp 'calc-original-buffer)
 513            (boundp 'calc-return-buffer)
 514            (boundp 'calc-one-window)
 515            (boundp 'calc-edit-handler)
 516            (boundp 'calc-restore-trail)
 517            (eq major-mode 'calc-edit-mode))
 518       (error "This command is valid only in buffers created by calc-edit."))
 519   (let ((buf (current-buffer))
 520         (original calc-original-buffer)
 521         (return calc-return-buffer)
 522         (one-window calc-one-window)
 523         (disp-trail calc-restore-trail))
 524     (save-excursion
 525       (if (or (null (buffer-name original))
 526               (progn
 527                 (set-buffer original)
 528                 (not (eq major-mode 'calc-mode))))
 529           (error "Original calculator buffer has been corrupted.")))
 530     (goto-char (point-min))
 531     (if (looking-at "Calc Edit\\|Editing ")
 532         (forward-line 1))
 533     (if (buffer-modified-p)
 534         (eval calc-edit-handler))
 535     (if one-window
 536         (delete-window))
 537     (if (get-buffer-window return)
 538         (select-window (get-buffer-window return))
 539       (switch-to-buffer return))
 540     (if keep
 541         (bury-buffer buf)
 542       (kill-buffer buf))
 543     (if disp-trail
 544         (calc-wrapper
 545          (calc-trail-display 1 t)))
 546     (message ""))
 547 )
 548
 549 (defun calc-edit-cancel ()
 550   "Cancel calc-edit mode.  Ignore the Calc Edit buffer and don't change stack."
 551   (interactive)
 552   (let ((calc-edit-handler nil))
 553     (calc-edit-finish))
 554   (message "(Cancelled)")
 555 )
 556
 557 (defun calc-finish-stack-edit (num)
 558   (let ((buf (current-buffer))
 559         (str (buffer-substring (point) (point-max)))
 560         (start (point))
 561         pos)
 562     (if (and (integerp num) (> num 1))
 563         (while (setq pos (string-match "\n." str))
 564           (aset str pos ?\,)))
 565     (switch-to-buffer calc-original-buffer)
 566     (let ((vals (let ((calc-language nil)
 567                       (math-expr-opers math-standard-opers))
 568                   (and (string-match "[^\n\t ]" str)
 569                        (math-read-exprs str)))))
 570       (if (eq (car-safe vals) 'error)
 571           (progn
 572             (switch-to-buffer buf)
 573             (goto-char (+ start (nth 1 vals)))
 574             (error (nth 2 vals))))
 575       (calc-wrapper
 576        (if (symbolp num)
 577            (progn
 578              (set num (car vals))
 579              (calc-refresh-evaltos num))
 580          (if disp-trail
 581              (calc-trail-display 1 t))
 582          (and vals
 583               (let ((calc-simplify-mode (if (eq last-command-char ?\C-j)
 584                                             'none
 585                                           calc-simplify-mode)))
 586                 (if (>= num 0)
 587                     (calc-enter-result num "edit" vals)
 588                   (calc-enter-result 1 "edit" vals (- num)))))))))
 589 )
 590
 591
 592
 593