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