1#!MUNGERPATH 2 3; Copyright (c) 2005-2019 James Bailie <jimmy@mammothcheese.ca> 4; All rights reserved. 5; 6; Redistribution in source form, with or without modification, is permitted 7; provided that the following conditions are met: 8; 9; * Redistributions of source code must retain the above copyright 10; notice, this list of conditions and the following disclaimer. 11; * The name of James Bailie may not be used to endorse or promote 12; products derived from this software without specific prior written permission. 13; 14; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" 15; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 18; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 19; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 20; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 21; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 22; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 23; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 24; POSSIBILITY OF SUCH DAMAGE. 25 26; Make lisp errors fatal to interpreter. 27 28(fatal) 29 30; Make GC more frequent. This keeps the garbage small and results in no 31; noticeable pause during collection. 32 33(gc_freq 65536) 34 35(unless (and (isatty 0) (isatty 1)) 36 (die "The stdin and stdout of dkns must be connected to a terminal device.")) 37 38; Version number as a string. 39 40(setq dkns_version "1.100") 41 42; Makes SIGINT and SIGTERM harmless. 43 44(block) 45 46; Used to specify a repeat count for a future command. 47 48(setq count 0) 49 50; Use to notify toplevel loop when SIGWINCH has been received. 51 52(setq winch 0) 53 54; Opens a buffer to hold text, and another to be the clipboard. 55 56(setq current_buffer (open)) 57(setq clipboard (open)) 58 59; The undo and redo buffers. 60 61(setq undo (open)) 62(setq redo (open)) 63 64(switch current_buffer) 65 66; Stack to hold saved clipboards. 67 68(setq clipboard_stack (stack)) 69 70; Stack to hold saved files. 71 72(setq file_stack (stack)) 73 74; Table to hold tags 75 76(setq tags (table)) 77 78; Last modification time of tags file. 79 80(setq tags_mtime 0) 81 82; Boolean indicates whether there are unsaved changes in the buffer. 83 84(setq dirty 0) 85 86; Bound to closure implementing last user command. 87 88(setq last_cmd 0) 89(setq last_count 0) 90 91; Booleans to indicate whether auto_wrapping and auto_indenting are active. 92 93(setq auto_indent 0) 94(setq auto_wrap 0) 95 96; Regular expression to detect whether or not lines are terminated. 97 98(setq term_rx (regcomp (stringify (char 10) "$"))) 99 100; Regular expressions to match delimiter characters. 101 102(setq paren_rx (regcomp "\\(|\\)")) 103(setq bracket_rx (regcomp "\\[|\\]")) 104(setq brace_rx (regcomp "\\{|\\}")) 105 106; Regular expressions for detecting blank lines, and lines with leading 107; whitespace. 108 109(setq whitespace_rx (regcomp "^[\b\t]*$")) 110(setq leading_whitespace_rx (regcomp "^[\b\t]+")) 111 112; Regular expressions used to find the ending points of sentences and 113; paragraphs, and the starting points of function bodies. 114 115(setq sent_rx (regcomp "[.?!][\"']?(\b\b|$)")) 116(setq para_rx (regcomp "^([\b\t]*|\\..*)$")) 117 118; Note that this regexp contains an escaped opening parenthesis and so will 119; screw up the showmatch feature of your editor. 120 121(setq func_rx (regcomp "^(\\(|\\{|\\.S)")) 122 123; History list of filenames. Maintained by get_string. 124 125(setq history ()) 126 127; List of buffer coordinates specifying one endpoint of the region. The other 128; is the cursor position. 129 130(setq mark ()) 131 132; Coordinates in buffer of cursor location. y starts at 1. 133 134(setq y 1) 135(setq x 0) 136 137; Coordinates on screen of cursor location. r starts at 0. 138 139(setq r 0) 140(setq c 0) 141 142; Last modification time of file associated with the buffer. 143 144(setq mtime (time)) 145 146; The filenname currently associated with the buffer. 147 148(setq filename "") 149 150; The tab_stop frequency. 151 152(setq tab_stop 8) 153 154; The auto_wrapper's desired line-length. 155 156(setq line_length 75) 157 158; Boolean indicating whether the showmatch facility is turned on or off. 159 160(setq show_match 0) 161 162; The index of the column at the left edge of the screen (> 0 when the screen 163; has been horizontally scrolled). 164 165(setq base 0) 166 167; The screen column the cursor "desires" to remain on, when moving to different lines. 168 169(setq goal 0) 170 171; The number of lines and columns on the screen. 172 173(setq num_lines (lines)) 174(setq num_cols (cols)) 175 176; The screen line index of the status line. 177 178(setq status_line (- num_lines 1)) 179 180; Wrapper function for the "insert" intrinsic, to save undo information. 181 182(setq do_insert 183 (lambda (idx line how) 184 (switch redo) 185 (when (lastline) (empty)) 186 (switch current_buffer) 187 188 (cond ((eq how 0) (save_change (if (lastline) "R" "D") idx undo)) 189 ((> how 0) (save_change "D" (+ idx 1) undo)) 190 (1 (save_change "D" idx undo))) 191 192 (insert idx line how))) 193 194; Wrapper function for the "delete" intrinsic to save undo information. 195 196(setq do_delete 197 (lambda (idx) 198 (switch redo) 199 (when (lastline) (empty)) 200 (switch current_buffer) 201 202 (save_change "I" idx undo) 203 (delete idx))) 204 205; Function to store undo and redo information. 206 207(let ((saved "")) 208 209 (setq save_change 210 (lambda (type idx buf) 211 (setq saved 212 (if (or (eq type "R") (eq type "I")) 213 (retrieve idx) 214 "")) 215 216 (when (eq type "I") (dec idx)) 217 218 (switch buf) 219 (insert (lastline) (join ":" type (stringify idx) (stringify x) saved) 1) 220 (switch current_buffer)))) 221 222; Function to perform undo and redo operations. 223 224(let ((buf 0) 225 (buf_name "") 226 (other_buf 0) 227 (line ()) 228 (restored "") 229 (type "") 230 (nx 0) 231 (idx 0)) 232 233 (setq restore_change 234 (lambda (rdo) 235 (setq buf undo) 236 (setq buf_name "Undo") 237 (setq other_buf redo) 238 239 (when rdo 240 (setq buf redo) 241 (setq buf_name "Redo") 242 (setq other_buf undo)) 243 244 (switch buf) 245 246 (if (not (lastline)) 247 (progn 248 (switch current_buffer) 249 (message (stringify buf_name " buffer is empty.") 1)) 250 251 (setq mark ()) 252 (setq dirty 1) 253 254 (setq line (split ":" (retrieve (lastline)) 4)) 255 (delete (lastline)) 256 (switch current_buffer) 257 258 (setq type (car line)) 259 (setq idx (digitize (cadr line))) 260 (setq nx (digitize (caddr line))) 261 (setq restored (cadddr line)) 262 263 (cond ((eq type "R") 264 (save_change "R" idx other_buf) 265 (insert idx restored 0)) 266 267 ((eq type "I") 268 (save_change "D" (+ idx 1) other_buf) 269 (insert idx restored 1)) 270 271 (1 (save_change "I" idx other_buf) 272 (delete idx)))) 273 274 (if (not (lastline)) 275 (progn 276 (clearline 0 0) 277 (print "~") 278 (goto 0 0)) 279 280 (goto_location idx (if (eq idx y) nx 0) 1) 281 (display (- y r) base tab_stop) 282 (goto r c))))) 283 284; Wrapper functions for restore_change. 285 286(setq undo_change 287 (lambda (repeat) 288 (while repeat 289 (restore_change 0) 290 (dec repeat)))) 291 292(setq redo_change 293 (lambda (repeat) 294 (while repeat 295 (restore_change 1) 296 (dec repeat)))) 297 298; Function to scroll screen horizontally if cursor position 299; has been moved to a non-visible location. 300 301(setq compensate 302 (lambda () 303 304 (let ((len (- num_cols 1))) 305 306 (cond ((< c base) 307 (setq base c) 308 (setq c 0) 309 (display (- y r) base tab_stop)) 310 311 ((> (- c base) len) 312 (setq base (- c len)) 313 (setq c len) 314 (display (- y r) base tab_stop)) 315 316 (base (setq c (- c base))))) 317 318 (goto r c))) 319 320; Function to move cursor as close as possible to the goal column. 321 322(let ((off 0) 323 (len 0) 324 (last 0)) 325 326 (setq seek_goal 327 (lambda () 328 (setq off (and x (cadr (slice y 0 x tab_stop 1)))) 329 (setq len (car (slice y 0 0 tab_stop 1))) 330 (setq last (and len (- len 1))) 331 332 (when (> x last) (setq x last)) 333 334 (while (and (< x last) (< (+ x off) goal)) 335 (inc x) 336 (setq off (cadr (slice y 0 x tab_stop 1)))) 337 338 (while (and x (> (+ x off) goal)) 339 (dec x) 340 (setq off (cadr (slice y 0 x tab_stop 1)))) 341 342 (setq c (+ x off)) 343 (compensate)))) 344 345; Function to adjust cursor x position to account for tab expansion. 346 347(setq add_offset 348 (lambda () 349 (let ((off (and x (cadr (slice y 0 x tab_stop 1))))) 350 (setq c (+ x off))))) 351 352; Function to move cursor one character forward in buffer. 353 354(let ((len 0) 355 (end 0) 356 (last 0)) 357 358 (setq forw_char 359 (lambda (repeat) 360 (setq last (lastline)) 361 (setq len (car (slice y 0 0 1 1))) 362 (setq end (and len (- len 1))) 363 364 (while repeat 365 (if (eq x end) 366 (unless (eq y last) 367 (forw_line 1) 368 (start_of_line 0)) 369 370 (inc x)) 371 (dec repeat)) 372 373 (add_offset) 374 (compensate) 375 (setq goal (+ base c))))) 376 377; Function to move cursor one character backward in buffer. 378 379(setq back_char 380 (lambda (repeat) 381 (while repeat 382 (if (eq x 0) 383 (unless (eq y 1) 384 (back_line 1) 385 (end_of_line 1)) 386 387 (dec x)) 388 (dec repeat)) 389 390 (add_offset) 391 (compensate) 392 (setq goal (+ base c)))) 393 394; Functions to determine classification of specified character. Used by word 395; motion functions. 396 397(setq is_word 398 (lambda (c) 399 (setq c (code c)) 400 (or (and (<= c 57) (>= c 48)) 401 (and (<= c 90) (>= c 65)) 402 (and (<= c 122) (>= c 97))))) 403 404(setq is_special 405 (lambda (c) 406 (setq c (code c)) 407 (or (and (<= c 47) (>= c 33)) 408 (and (<= c 64) (>= c 58)) 409 (and (<= c 96) (>= c 91)) 410 (and (<= c 126) (>= c 123))))) 411 412(setq is_space 413 (lambda (c) 414 (and (not (is_word c)) (not (is_special c))))) 415 416; Function to find word boundaries. Used by forw_word. 417 418(let ((chars ()) 419 (goal "") 420 (other 0)) 421 422 (setq find_word_forw 423 (lambda ((start)) 424 (when (lastline) 425 (setq chars (split "" (slice y (if start (car start) x) 0 1 0))) 426 (setq goal "") 427 (setq other 0) 428 429 (if (or (not chars) (not (car chars))) 430 (progn 431 (setq x (- (car (slice y 0 0 tab_stop 1)) 1)) 432 0) 433 434 (cond ((is_word (car chars)) 435 (setq goal is_word) 436 (setq other is_space)) 437 438 ((is_special (car chars)) 439 (setq goal is_special) 440 (setq other is_space)) 441 442 (1 (setq goal is_space))) 443 444 (while (and chars (goal (car chars))) 445 (setq x (+ x 1)) 446 (setq chars (cdr chars))) 447 448 (while (and other chars (other (car chars))) 449 (setq x (+ x 1)) 450 (setq chars (cdr chars))) 451 452 (if chars 453 1 454 (tailcall 0 (+ x 80)))))))) 455 456(let ((last 0) 457 (line "")) 458 459 (setq forw_word 460 (lambda (repeat) 461 (hide) 462 (setq last (lastline)) 463 (setq tmp "") 464 465 (while repeat 466 (catch 467 (while (and (not (find_word_forw)) (< y last)) 468 (forw_line 1) 469 (start_of_line 0) 470 (unless (or (match whitespace_rx (chomp (setq line (retrieve y)))) 471 (match leading_whitespace_rx line)) 472 (throw 1)))) 473 474 (dec repeat)) 475 476 (add_offset) 477 (compensate) 478 (show) 479 (setq goal (+ base c))))) 480 481(setq find_word_back 482 (lambda ((start)) 483 484 (if (not x) 485 0 486 487 (when (lastline) 488 (if start 489 (setq start (car start)) 490 (setq start (- x 80))) 491 492 (when (< start 0) 493 (setq start 0)) 494 495 (let ((chars (reverse (split "" (slice y start (- x start) 1 0)))) 496 (goal "") 497 (other 0)) 498 499 (if (not chars) 500 0 501 502 (cond ((is_word (car chars)) 503 (setq goal is_word)) 504 505 ((is_special (car chars)) 506 (setq goal is_special)) 507 508 (1 509 (setq goal is_space) 510 (setq other 1))) 511 512 (while (and chars (goal (car chars))) 513 (setq x (- x 1)) 514 (set 'chars (cdr chars))) 515 516 (if (or (not x) (not other)) 517 1 518 519 (if (not chars) 520 (tailcall find_word_back (- start 80)) 521 522 (cond ((is_word (car chars)) 523 (setq goal is_word)) 524 525 ((is_special (car chars)) 526 (setq goal is_special))) 527 528 (while (and chars (goal (car chars))) 529 (setq x (- x 1)) 530 (set 'chars (cdr chars))) 531 532 1)))))))) 533 534(setq back_word 535 (lambda (repeat) 536 (hide) 537 538 (while repeat 539 (while (and (not (find_word_back)) (> y 1)) 540 (back_line 1) 541 (setq x (car (slice y 0 0 1 1)))) 542 (dec repeat)) 543 544 (add_offset) 545 (compensate) 546 (show) 547 (setq goal (+ base c)))) 548 549; Function to move cursor forward one line. 550 551(let ((last 0) 552 (bottom 0) 553 (flag 0)) 554 555 (setq forw_line 556 (lambda (repeat) 557 (when (setq last (lastline)) 558 (setq bottom (- num_lines 2)) 559 (setq flag 0) 560 561 (while (and repeat (< y last)) 562 (dec repeat) 563 (inc y) 564 (if (< r bottom) 565 (inc r) 566 (inc flag))) 567 568 (when flag 569 (if (> flag 1) 570 (display (- y r) base tab_stop) 571 572 (scrollup) 573 (goto bottom 0) 574 (print (chomp (slice y base num_cols tab_stop 0))))) 575 576 (seek_goal))))) 577 578; Function to move cursor backward one line. 579 580(let ((flag 0)) 581 582 (setq back_line 583 (lambda (repeat) 584 (setq flag 0) 585 586 (while (and repeat (> y 1)) 587 (dec repeat) 588 (dec y) 589 (if (> r 0) 590 (dec r) 591 (inc flag))) 592 593 (when flag 594 (if (> flag 1) 595 (display (- y r) base tab_stop) 596 597 (scrolldn) 598 (clearline status_line 0) 599 (goto 0 0) 600 (print (chomp (slice y base num_cols tab_stop 0))))) 601 602 (seek_goal)))) 603 604; Function to move cursor to the beginning of the line. 605 606(setq start_of_line 607 (lambda (show) 608 (when base 609 (setq base 0) 610 (clearline status_line 0) 611 (display (- y r) base tab_stop)) 612 613 (setq x 0) 614 (setq c 0) 615 (setq goal 0) 616 (when show 617 (goto r c)))) 618 619; Function to move cursor to the end of the line. 620 621(setq end_of_line 622 (lambda (ignored) 623 (setq x (- (car (slice y 0 0 1 1)) 1)) 624 (add_offset) 625 (compensate) 626 (setq goal (+ base c)))) 627 628; Wrapper function to scroll buffer up by one screenful. 629 630(setq forw_screen 631 (lambda (repeat) 632 (low 1) 633 (forw_lines (* repeat (- num_lines 2))) 634 (high 1))) 635 636; Wrapper function to scroll buffer down by one screenful. 637 638(setq back_screen 639 (lambda (repeat) 640 (high 1) 641 (back_lines (* repeat (- num_lines 2))) 642 (low 1))) 643 644; Function to perform up-scrolling of buffer by multiple lines. Cursor is 645; moved to last screen line, or last buffer line, whichever is further down 646; on the screen. 647 648(let ((last 0)) 649 650 (setq forw_lines 651 (lambda (add) 652 (setq last (lastline)) 653 654 (when (< y last) 655 (if (> (+ y add) last) 656 (progn 657 (setq y last) 658 (when (< last num_lines) 659 (setq r (- last 1)))) 660 661 (setq r (- num_lines 2)) 662 (setq y (+ y add)))) 663 664 (display (- y r) base tab_stop) 665 (seek_goal)))) 666 667; Function to perform down-scrolling of buffer by multiple lines. 668; Cursor is moved to first screen line. 669 670(setq back_lines 671 (lambda (sub) 672 (when (> y 1) 673 (setq r 0) 674 (setq y (if (< (- y sub) 1) 1 (- y sub)))) 675 676 (setq base 0) 677 (setq c 0) 678 (setq x 0) 679 680 (display (- y r) base tab_stop) 681 (seek_goal))) 682 683; Function to scroll buffer upward by one line, without altering cursor 684; position relative to buffer content, if possible. 685 686(let ((bottom 0) 687 (last 0)) 688 689 (setq forw_scroll 690 (lambda (repeat) 691 (setq last (lastline)) 692 693 (while repeat 694 (when (not (eq (- y r) last)) 695 (when (< (dec r) 0) 696 (setq r 0) 697 (inc y)) 698 699 (scrollup) 700 (goto (- status_line 1) 0) 701 (setq bottom (+ (- y r) (- status_line 1))) 702 703 (if (> bottom last) 704 (print "~") 705 (print (chomp (slice bottom base num_cols tab_stop 0))))) 706 707 (dec repeat)) 708 709 (seek_goal)))) 710 711; Function to scroll buffer downward by one line, without altering 712; cursor position relative to buffer content, if possible. 713 714(let ((top 0)) 715 716 (setq back_scroll 717 (lambda (repeat) 718 (setq top (- y r)) 719 720 (while repeat 721 (unless (eq top 1) 722 (dec top) 723 (inc r) 724 725 (when (eq r status_line) 726 (dec r) 727 (setq x base) 728 (setq c 0) 729 (dec y)) 730 731 (scrolldn) 732 (clearline status_line 0) 733 (goto 0 0) 734 (print (chomp (slice top base num_cols tab_stop 0))) 735 (seek_goal)) 736 737 (dec repeat))))) 738 739; Function to rotate a history list forward. Called by get_string. 740 741(let ((back ()) 742 (forw ()) 743 (new "")) 744 745 (setq forw_history 746 (lambda (str) 747 (setq back ()) 748 (setq forw ()) 749 (setq new "") 750 751 (when history 752 (setq back (car history)) 753 (setq forw (cadr history))) 754 755 (if (not forw) 756 str 757 758 (unless (or (match whitespace_rx str) 759 (and back (eq (car back) str))) 760 (setq back (cons str back))) 761 762 (setq new (car forw)) 763 (setq forw (cdr forw)) 764 (setq history (list back forw)) 765 766 new)))) 767 768; A function to rotate a history list backward. Called by get_string. 769 770(let ((back ()) 771 (forw ()) 772 (new "")) 773 774 (setq back_history 775 (lambda (str) 776 (setq back ()) 777 (setq forw ()) 778 (setq new "") 779 780 (when history 781 (setq back (car history)) 782 (setq forw (cadr history))) 783 784 (if (not back) 785 str 786 787 (unless (and forw (eq (car forw) str)) 788 (setq forw (cons str forw))) 789 790 (setq new (car back)) 791 (setq back (cdr back)) 792 (setq history (list back forw)) 793 794 new)))) 795 796; Function to rebuild a history list, removing empty string elements. 797 798(let ((back ()) 799 (forw ())) 800 801 (setq consolidate_history 802 (lambda (ch lh str) 803 (setq back ()) 804 (setq forw ()) 805 806 (when history 807 (setq back (remove str (remove lh (remove "" (car history))))) 808 (setq forw (remove str (remove lh (remove "" (cadr history)))))) 809 810 (setq forw (reverse forw)) 811 812 (when (and lh (not (eq lh str))) 813 (setq forw (append forw (list lh)))) 814 815 (when str 816 (setq forw (cons str forw))) 817 818 (setq history (list (append forw back) ())) 819 820 str))) 821 822; Function to perform filename completion and display the results to the user. 823; Called by get_string. 824 825(let ((ch "") 826 (str "") 827 (top "--") 828 (complete_func complete) 829 (len 0)) 830 831 (setq set_complete_func 832 (lambda (func) 833 (setq complete_func func))) 834 835 (setq complete_string 836 (lambda (str) 837 (setq top "--") 838 839 (setq ch (complete_func str)) 840 (setq str (car ch)) 841 (setq ch (cdr ch)) 842 843 (display (if (lastline) (- y r) 0) base tab_stop) 844 845 (setq len (length ch)) 846 847 (if (< len status_line) 848 (inc len) 849 (setq len status_line) 850 (setq top "- list truncated -")) 851 852 (clearline (- status_line len) 0) 853 (print top) 854 (dec len) 855 856 (while len 857 (clearline (- status_line len) 0) 858 (print (car ch)) 859 (dec len) 860 (setq ch (cdr ch))) 861 862 str))) 863 864; Function to get a string from the terminal with minimal editing features, a 865; browsable history and filename completion. 866 867(let ((len 0) 868 (len2 0) 869 (line "") 870 (lh "") 871 (mess 0) 872 (str2 "") 873 (m ()) 874 (complete_rx (regcomp "^[\b\t]*(([^\b\t]+[\b\t]+)*)([^\b\t]+)")) 875 (werase_rx (regcomp "^(.*[-_./:\b\t])?[^\b\t]+[\b\t]*$")) 876 (ch "")) 877 878 (setq get_string 879 (lambda (prompt str compl hist (allow_empty)) 880 (setq line "") 881 (setq lh "") 882 (setq mess 0) 883 (setq m ()) 884 (setq ch "") 885 (setq len (length prompt)) 886 (setq str (expand tab_stop str)) 887 (setq len2 (length str)) 888 889 (setq line (concat prompt 890 (if (< (+ len len2) num_cols) 891 str 892 (substring str (- len2 (- (- num_cols len) 1)) 0)))) 893 894 (setq len2 (length line)) 895 (clearline status_line 0) 896 (print line) 897 (goto status_line len2) 898 899 (catch 900 (while (not (eq (setq ch (get_char)) 10)) 901 902 (cond ((eq ch 3) (throw 0)) 903 ((eq ch 8) (setq str (chop str))) 904 905 ((and compl (eq ch 9)) 906 (setq m (matches complete_rx str)) 907 (setq mess 1) 908 (setq str2 (complete_string (if m (car (cdddr m)) ""))) 909 (when m (setq str (concat (cadr m) str2)))) 910 911 ((and hist (eq ch 14)) 912 (setq str (forw_history lh)) 913 (setq lh str)) 914 915 ((and hist (eq ch 16)) 916 (setq str (back_history lh)) 917 (setq lh str)) 918 919 ((eq ch 21) (setq str "")) 920 ((eq ch 22) (setq str (join "" str (char (get_char))))) 921 ((eq ch 23) (setq str (substitute werase_rx "\1" str))) 922 ((eq ch -2) (throw 0)) 923 924 ((eq ch 1) (setq str (concat str (char 9)))) 925 ((or (eq ch 9) (>= ch 32)) 926 (setq str (join "" str (char ch)))) 927 928 (1 (beep))) 929 930 (setq len2 (length (setq str2 (expand tab_stop str)))) 931 932 (setq line (join "" prompt 933 (if (< (+ len len2) num_cols) 934 str2 935 (substring str2 (- len2 (- (- num_cols len) 1)) 0)))) 936 937 (setq len2 (length line)) 938 (clearline status_line 0) 939 (print line) 940 (goto status_line len2))) 941 942 (when mess (display (if (lastline) (- y r) 0) base tab_stop)) 943 (goto r c) 944 945 (when hist 946 (consolidate_history ch lh str)) 947 948 (if (and (not (eq ch 3)) (or allow_empty str)) 949 str 950 (message "Cancelled." 1) 951 0)))) 952 953; Functions to save and load buffer. 954 955(setq reset_buffer 956 (lambda (file new) 957 (empty) 958 959 (setq dirty 0) 960 (setq y 1) 961 (setq x 0) 962 (setq r 0) 963 (setq c 0) 964 (setq goal 0) 965 (setq base 0) 966 (setq mark ()) 967 968 (switch undo) 969 (empty) 970 (switch redo) 971 (empty) 972 (switch current_buffer) 973 974 (if new 975 (setq mtime (time)) 976 (setq mtime (car (cdddr (stat file))))) 977 978 (setq filename file) 979 (message (stringify (basename file) (if new ": new file" "")) 0))) 980 981(let ((file "") 982 (type 0) 983 (fn "") 984 (nl_rx (regcomp (concat (char 10) "$"))) 985 (mk 0) 986 (mt 0) 987 (my 0) 988 (mx 0)) 989 990 (setq load_file_wrapper 991 (lambda (ignored) 992 (load_file 1))) 993 994 (setq save_settings 995 (lambda () 996 (setq mt mtime) 997 (setq my y) 998 (setq mx x) 999 (setq mk mark) 1000 (setq fn filename))) 1001 1002 (setq restore_settings 1003 (lambda (reload) 1004 (if (and reload (< (read 0 (setq filename fn)) 0)) 1005 (display 0 0 0) 1006 (goto_location my mx)) 1007 (setq mtime mt))) 1008 1009 ; Function load the buffer from a disk file. 1010 1011 (setq load_file 1012 (lambda (new (supplied)) 1013 (catch 1014 (when dirty 1015 (message "Unsaved changes! Continue? (y/n) " 1) 1016 (goto status_line 34) 1017 (unless (eq (get_char) 121) 1018 (clearline status_line 0) 1019 (goto r c) 1020 (throw 0))) 1021 1022 (if supplied 1023 (setq file (car supplied)) 1024 (unless (setq file (get_string "File: " "" 1 1)) 1025 (throw 0))) 1026 1027 (save_settings) 1028 1029 (when (not (setq type (exists file))) 1030 (when new 1031 (display 0 0 0) 1032 (reset_buffer file 1) 1033 (throw 1)) 1034 1035 (restore_settings 0) 1036 (message "file does not exist" 1) 1037 (throw 0)) 1038 1039 (when (eq type -1) 1040 (restore_settings 0) 1041 (message "path does not exist or search permission denied" 1) 1042 (throw 0)) 1043 1044 (when (not (eq type 1)) 1045 (restore_settings 0) 1046 (message (stringify file " is not a regular file.") 1) 1047 (throw 0)) 1048 1049 (reset_buffer file 0) 1050 (setq type (read 0 file)) 1051 1052 (cond ((stringp type) 1053 (restore_settings 1) 1054 (message type 1) 1055 (throw 0)) 1056 1057 ((eq type -2) 1058 (restore_settings 1) 1059 (message "permission denied" 1) 1060 (throw 0)) 1061 1062 (1 (setq filename file) 1063 (when (lastline) 1064 (unless (match nl_rx (retrieve (lastline))) 1065 (insert (lastline) (concat (retrieve (lastline)) (char 10)) 0))) 1066 (message (stringify type " lines.") 0))) 1067 1068 (display (if (lastline) 1 0) base tab_stop) 1069 (goto r c)))) 1070 1071 ; Function to write buffer content to disk file. 1072 1073 (setq save_file 1074 (lambda (ignored) 1075 (catch 1076 (if filename 1077 (setq file filename) 1078 1079 (unless (setq file (get_string "filename: " "" 1 1)) 1080 (throw 0))) 1081 1082 (when (setq type (exists file)) 1083 (cond ((eq type -1) 1084 (message "permission denied" 1) 1085 (throw 0)) 1086 1087 ((not (eq type 1)) 1088 (message (stringify file " is not a regular file.") 1) 1089 (throw 0)) 1090 1091 (1 (setq type (car (cdddr (stat file)))) 1092 (when (not (eq type mtime)) 1093 (message "File has changed on disk. Continue? (y/n) " 1) 1094 (unless (eq (get_char) 121) 1095 (message "Cancelled." 1) 1096 (throw 0)))))) 1097 1098 (when type 1099 (setq filename file)) 1100 1101 (setq type 1102 (if (lastline) 1103 (write 1 (lastline) filename 1 0) 1104 (write 0 0 filename 1 0))) 1105 1106 (when (stringp type) 1107 (message type 1) 1108 (throw 0)) 1109 1110 (setq mtime (car (cdddr (stat filename)))) 1111 (setq dirty 0) 1112 (message (stringify type " lines.") 0) 1113 1)))) 1114 1115; Function to set filename associated with buffer. 1116 1117(let ((file "")) 1118 1119 (setq set_filename 1120 (lambda (ignored) 1121 (when (setq file (get_string "new filename: " "" 1 1)) 1122 (when (lastline) (setq dirty 1)) 1123 (setq filename file))))) 1124 1125; Function to get an integer from the terminal. 1126 1127(let ((len 0) 1128 (ch "")) 1129 1130 (setq get_number 1131 (lambda (prompt num (allow_zero)) 1132 (setq len (length prompt)) 1133 (clearline status_line 0) 1134 (setq num (stringify num)) 1135 (print prompt num) 1136 1137 (catch 1138 (while (not (eq (setq ch (get_char)) 10)) 1139 1140 (cond ((eq ch 8) (setq num (chop num))) 1141 ((eq ch 3) (throw 0)) 1142 ((eq ch 21) (setq num "")) 1143 ((and (> ch 47) (< ch 58)) 1144 (setq num (stringify num (char ch)))) 1145 1146 (1 (beep))) 1147 1148 (clearline status_line 0) 1149 (print prompt num) 1150 (goto status_line (+ len (length num))))) 1151 1152 (setq num (digitize num)) 1153 (clearline status_line 0) 1154 (goto r c) 1155 1156 (if (and (not (eq ch 3)) (or allow_zero num)) 1157 num 1158 (message "Cancelled." 1) 1159 -1)))) 1160 1161; Function to move cursor to specified buffer location. 1162 1163(let ((top 0) 1164 (gap 0) 1165 (last 0) 1166 (half 0)) 1167 1168 (setq goto_location 1169 (lambda (line col (udo)) 1170 1171 (if (or (not (setq last (lastline))) (< line 1) (> line last)) 1172 (if udo 1173 (tailcall 0 (lastline) col 1) 1174 (message "Line number out of range." 1)) 1175 1176 (setq top (- y r)) 1177 (setq gap (- line top)) 1178 (setq half (/ status_line 2)) 1179 (setq y line) 1180 1181 (if (and (>= gap 0) (< gap status_line)) 1182 (setq r (- y top)) 1183 1184 (setq r (if (<= y half) (- y 1) half)) 1185 (display (- y r) base tab_stop)) 1186 1187 (if (or (< col 0) (>= col (car (slice line 0 0 tab_stop 1)))) 1188 (if udo 1189 (tailcall 0 line 0 1) 1190 (message "Column out of range." 1)) 1191 1192 (setq x col) 1193 (add_offset) 1194 (compensate) 1195 (setq goal (+ base c)) 1196 1))))) 1197 1198; Wrapper function to move cursor to the start of a specified buffer line. 1199 1200(let ((number 0)) 1201 1202 (setq goto_line_number 1203 (lambda (ignored) 1204 (when (>= (setq number (get_number "line: " "")) 0) 1205 (goto_location number 0))))) 1206 1207; Wrapper function to move the cursor to the last line of the buffer. 1208 1209(let ((len 0) 1210 (last 0)) 1211 1212 (setq end_of_buffer 1213 (lambda (ignored) 1214 (when (setq last (lastline)) 1215 (setq len (- (car (slice last 0 0 tab_stop 1)) 1)) 1216 (goto_location last len))))) 1217 1218; Wrapper function to move the cursor to the first line of the buffer. 1219 1220(setq start_of_buffer 1221 (lambda (ignored) 1222 (goto_location 1 0))) 1223 1224; Function to place cursor on highest or lowest line on screen. 1225 1226(let ((last 0) 1227 (number 0)) 1228 1229 (setq goto_top_bottom 1230 (lambda (idx) 1231 1232 (cond ((eq idx 0) 1233 (setq number (- y r))) 1234 1235 ((eq idx 1) 1236 (setq last (lastline)) 1237 (setq number (if (> (setq number (+ (- y r) (- status_line 1))) last) 1238 last 1239 number)))) 1240 1241 (goto_location number 0)))) 1242 1243; Wrapper functions to move cursor to the highest or lowest line on screen. 1244 1245(setq high 1246 (lambda (ignored) 1247 (goto_top_bottom 0))) 1248 1249(setq low 1250 (lambda (ignored) 1251 (goto_top_bottom 1))) 1252 1253; Function to place cursor at start of middle screen line. 1254 1255(let ((last 0) 1256 (top 0) 1257 (half 0)) 1258 1259 (setq goto_middle 1260 (lambda (ignored) 1261 (setq last (lastline)) 1262 (setq top (- y r)) 1263 (setq half (/ status_line 2)) 1264 1265 (setq c 0) 1266 (setq base 0) 1267 (setq goal 0) 1268 (setq x 0) 1269 1270 (if (< (- last top) status_line) 1271 (progn 1272 (setq r (/ (- last top) 2)) 1273 (setq y (+ r top))) 1274 1275 (setq y (- (+ top half) 1)) 1276 (setq r (- half 1))) 1277 1278 (goto r c)))) 1279 1280; Function to set mark. Used by deletion functions. Not settable by user. 1281 1282(setq set_mark 1283 (lambda () 1284 (setq mark (list y x)))) 1285 1286; Function to put the endpoints of the region in ascending order. Called by 1287; clipboard_operation. 1288 1289(setq order_region 1290 (lambda (first second) 1291 (cond ((> (car first) (car second)) 1292 (list second first)) 1293 1294 ((eq (car first) (car second)) 1295 (cond ((eq (cadr first) (cadr second)) 1296 ()) 1297 1298 ((> (cadr first) (cadr second)) 1299 (list second first)) 1300 1301 (1 (list first second)))) 1302 1303 (1 (list first second))))) 1304 1305; Function which appends the region to the clipboard. Called by clipboard_operation. 1306 1307(let ((line "") 1308 (diff 0) 1309 (idx 0)) 1310 1311 (setq copy_region 1312 (lambda (first second) 1313 1314 (setq line (substring (retrieve (car first)) 1315 (cadr first) 1316 (if (eq (car first) (car second)) 1317 (- (cadr second) (cadr first)) 1318 0))) 1319 1320 (switch clipboard) 1321 1322 (setq idx (lastline)) 1323 (if (or (not idx) (match term_rx (retrieve idx))) 1324 (insert idx line 1) 1325 (insert idx (join "" (retrieve idx) line) 0) 1326 (dec idx)) 1327 1328 (switch current_buffer) 1329 1330 (when (setq diff (- (car second) (car first))) 1331 (inc idx) 1332 1333 (when (> diff 1) 1334 (transfer current_buffer (+ (car first) 1) (- (car second) 1) clipboard idx) 1335 (setq idx (+ idx (- diff 1)))) 1336 1337 (setq line (if (cadr second) (substring (retrieve (car second)) 0 (cadr second)) "")) 1338 1339 (when line 1340 (switch clipboard) 1341 (insert idx line 1) 1342 (switch current_buffer)))))) 1343 1344; Function which deletes region from buffer. Called by clipboard_operation. 1345 1346(let ((idx 0)) 1347 1348 (setq delete_region 1349 (lambda (first second) 1350 (if (or (eq (car first) (car second)) (cadr first)) 1351 (progn 1352 (do_insert (car first) 1353 (join "" 1354 (if (cadr first) (substring (retrieve (car first)) 0 (cadr first)) "") 1355 (substring (retrieve (car second)) (cadr second) 0)) 1356 0) 1357 1358 (when (- (car second) (car first)) 1359 (setq idx (+ (car first) 1)) 1360 (for (n idx (car second)) 1361 (do_delete idx)))) 1362 1363 (setq idx (car first)) 1364 (for (n idx (- (car second) 1)) 1365 (do_delete idx)) 1366 (when (cadr second) 1367 (do_insert idx (substring (retrieve idx) (cadr second) 0) 0)))))) 1368 1369; Master function to perform deletions to the clipboard. 1370 1371(let ((first ()) 1372 (second ()) 1373 (tmp ())) 1374 1375 (setq clipboard_operation 1376 (lambda (kill append) 1377 1378 ; Refuse to operate on an empty region. 1379 1380 (if (or (not mark) (not (setq tmp (order_region (list y x) mark)))) 1381 (message "Nothing to delete." 1) 1382 1383 (setq first (car tmp)) 1384 (setq second (cadr tmp)) 1385 1386 ; Clear the clipboard if we're not deleting multiple whole 1387 ; lines. 1388 1389 (unless append 1390 (switch clipboard) 1391 (empty) 1392 (switch current_buffer)) 1393 1394 ; Copy the region to the clipboard. 1395 1396 (message "Working..." 0) 1397 (copy_region first second) 1398 1399 (if (not kill) 1400 (message "Region saved." 0) 1401 1402 ; Replace the lines of the region with the result of removing 1403 ; the selected text. 1404 1405 (delete_region first second) 1406 (setq dirty 1) 1407 1408 ; Update the screen. 1409 1410 (redisplay_after_deletion first second) 1411 1412 ; Clear the mark so the user cannot accidentally use it. 1413 1414 (setq mark ())))))) 1415 1416; Function to redraw the screen after a deletion has been performed. 1417 1418(let ((row 0) 1419 (line 0) 1420 (last 0) 1421 (top 0)) 1422 1423 (setq redisplay_after_deletion 1424 (lambda (first second) 1425 (setq last (lastline)) 1426 1427 (if (eq (car first) (car second)) 1428 (progn 1429 (clearline r 0) 1430 (print (slice y base num_cols tab_stop 0))) 1431 1432 (setq top (- y r)) 1433 (when (> top (setq line (car first))) 1434 (setq line top)) 1435 1436 (setq row (- line top)) 1437 1438 (while (< row status_line) 1439 (clearline row 0) 1440 (print (if (> line last) "~" (slice line base num_cols tab_stop 0))) 1441 (inc row) 1442 (inc line))) 1443 1444 (clearline status_line 0) 1445 (goto_location (car first) (cadr first))))) 1446 1447; Wrapper functions to delete characters. 1448 1449(setq delete_char_forw 1450 (lambda (repeat) 1451 (set_mark) 1452 (forw_char repeat) 1453 (clipboard_operation 1 0))) 1454 1455(setq delete_char_back 1456 (lambda (repeat) 1457 (set_mark) 1458 (back_char repeat) 1459 (clipboard_operation 1 0))) 1460 1461; Wrapper functions to delete words. 1462 1463(setq delete_word_forw 1464 (lambda (repeat) 1465 (set_mark) 1466 (forw_word repeat) 1467 (clipboard_operation 1 0))) 1468 1469(setq delete_word_back 1470 (lambda (repeat) 1471 (set_mark) 1472 (back_word repeat) 1473 (clipboard_operation 1 0))) 1474 1475; Function to delete whitespace from cursor position to next non-whitespace 1476; character, or end of line. 1477 1478(let ((line "")) 1479 1480 (setq delete_whitespace 1481 (lambda (ignored) 1482 (setq line (retrieve y)) 1483 1484 (do_insert y 1485 (join "" 1486 (if x (substring line 0 x) "") 1487 (substitute leading_whitespace_rx "" (substring line x 0))) 1488 0) 1489 1490 (clearline r 0) 1491 (print (slice y base num_cols tab_stop 0)) 1492 (goto r c)))) 1493 1494; Wrapper functions to delete portions of lines before or after cursor position. 1495 1496(setq delete_end_of_line 1497 (lambda (repeat) 1498 (set_mark) 1499 (forw_line (dec repeat)) 1500 (end_of_line 1) 1501 1502 (if repeat 1503 (progn 1504 (forw_line 1) 1505 (start_of_line 0)) 1506 1507 (when (and (eq y (car mark)) (eq x (cadr mark)) (< y (lastline))) 1508 (forw_char 1))) 1509 1510 (clipboard_operation 1 (eq last_cmd delete_end_of_line)))) 1511 1512(setq delete_start_of_line 1513 (lambda (ignored) 1514 (set_mark) 1515 (start_of_line 1) 1516 (clipboard_operation 1 0))) 1517 1518(setq delete_start_of_text 1519 (lambda (ignored) 1520 (set_mark) 1521 (start_of_text 1) 1522 (clipboard_operation 1 0))) 1523 1524; Function to copy the region to the clipboard. 1525 1526(setq copy_user_region 1527 (lambda (ignored) 1528 (clipboard_operation 0 0))) 1529 1530; Functions to set bookmarks and move to cursor to the beginning of 1531; bookmarked lines. 1532 1533(let ((bookmark "") 1534 (bookmark_history ()) 1535 (tmp "") 1536 (old ())) 1537 1538 (setq set_bookmark 1539 (lambda (ignored) 1540 (setq old history) 1541 (setq history bookmark_history) 1542 1543 (when (setq bookmark (get_string "bookmark: " "" 0 1)) 1544 (setmark bookmark y)) 1545 1546 (setq bookmark_history history) 1547 (setq history old))) 1548 1549 (setq goto_bookmark 1550 (lambda (ignored) 1551 (setq old history) 1552 (setq history bookmark_history) 1553 (setq tmp -1) 1554 1555 (when (setq bookmark (get_string "bookmark: " "" 0 1)) 1556 (cond ((eq 0 (setq tmp (getmark bookmark))) 1557 (message (stringify "Bookmark " bookmark " not set.") 1)) 1558 1559 ((eq -1 tmp) 1560 (message "Bookmarked line deleted." 1)) 1561 1562 (1 (goto_location tmp 0) 1563 (start_of_text 1)))) 1564 1565 (setq bookmark_history history) 1566 (setq history old) 1567 tmp))) 1568 1569; Functions to move cursor to beginning of text on current, previous and next buffer 1570; lines. 1571 1572(let ((line "")) 1573 1574 (setq start_of_text 1575 (lambda (ignored) 1576 (when base 1577 (setq base 0) 1578 (clearline status_line 0) 1579 (display (- y r) base tab_stop)) 1580 1581 (setq x 0) 1582 (setq c 0) 1583 (setq goal 0) 1584 1585 (setq line (chomp (retrieve y))) 1586 1587 (when (and (match leading_whitespace_rx line) 1588 (not (match whitespace_rx line))) 1589 (forw_word 1)) 1590 1591 (setq goal (+ base c)) 1592 (seek_goal)))) 1593 1594(setq back_start_of_text 1595 (lambda (repeat) 1596 (hide) 1597 (back_line repeat) 1598 (start_of_text 1) 1599 (show))) 1600 1601(setq forw_start_of_text 1602 (lambda (repeat) 1603 (hide) 1604 (forw_line repeat) 1605 (start_of_text 1) 1606 (show))) 1607 1608; Functions to move the cursor to the location of matches on regular 1609; expressions. 1610 1611(setq forw_sent 1612 (lambda (repeat) 1613 (while (and repeat (find_pattern 1 sent_rx 1 0)) 1614 (dec repeat) 1615 (setq goal (+ base c))))) 1616 1617(setq back_sent 1618 (lambda (repeat) 1619 (while (and repeat (find_pattern -1 sent_rx 1 0)) 1620 (dec repeat) 1621 (setq goal (+ base c))))) 1622 1623(setq forw_para 1624 (lambda (repeat) 1625 (while (and repeat (find_pattern 1 para_rx 1 0)) 1626 (dec repeat) 1627 (setq goal (+ base c))))) 1628 1629(setq back_para 1630 (lambda (repeat) 1631 (while (and repeat (find_pattern -1 para_rx 1 0)) 1632 (dec repeat) 1633 (setq goal (+ base c))))) 1634 1635(setq forw_func 1636 (lambda (repeat) 1637 (while (and repeat (find_pattern 1 func_rx 1 0)) 1638 (dec repeat) 1639 (setq goal (+ base c))))) 1640 1641(setq back_func 1642 (lambda (repeat) 1643 (while (and repeat (find_pattern -1 func_rx 1 0)) 1644 (dec repeat) 1645 (setq goal (+ base c))))) 1646 1647; Functions to move the cursor to the location of matches on 1648; user-specified regular expressions. 1649 1650(let ((search_history ()) 1651 (last_rx "") 1652 (old ()) 1653 (pat "") 1654 (rx "")) 1655 1656 (setq search 1657 (lambda (dir last wrap repeat) 1658 (setq pat "") 1659 1660 (if (and last (not (regexpp last_rx))) 1661 (progn 1662 (message "No stored pattern." 1) 1663 0) 1664 1665 (if last 1666 (setq rx last_rx) 1667 1668 (setq old history) 1669 (setq history search_history) 1670 1671 (when (setq pat (get_string "Pattern: " "" 0 1)) 1672 (if (stringp (setq rx (regcomp pat))) 1673 (message rx 1) 1674 (when pat (setq last_rx rx)))) 1675 1676 (setq search_history history) 1677 (setq history old)) 1678 1679 (when (and (regexpp rx) (or last pat)) 1680 (while (and repeat (find_pattern dir rx 0 wrap)) 1681 (dec repeat)) 1682 (not repeat)))))) 1683 1684(setq forw_search 1685 (lambda (repeat) 1686 (search 1 0 1 repeat))) 1687 1688(setq back_search 1689 (lambda (repeat) 1690 (search -1 0 1 repeat))) 1691 1692(setq forw_search_again 1693 (lambda (repeat) 1694 (search 1 1 1 repeat))) 1695 1696(setq back_search_again 1697 (lambda (repeat) 1698 (search -1 1 1 repeat))) 1699 1700; Core function which performs the actual search for matches on regular 1701; expressions in the buffer. 1702 1703; dir irection of search 1704; rx compiled regexp 1705; last move to last line on failure 1706; wrap search wraps around on failure 1707 1708(let ((f ()) 1709 (oy 0) 1710 (ox 0)) 1711 1712 (setq find_pattern 1713 (lambda (dir rx last wrap) 1714 (setq oy y) 1715 (setq ox x) 1716 1717 (if (not (car (setq f (find dir y x rx (and (not last) wrap))))) 1718 (if (not last) 1719 (progn 1720 (message "Not found." 1) 1721 0) 1722 1723 (when last 1724 (if (< dir 0) 1725 (goto_location 1 0) 1726 (end_of_buffer 0) 1727 (end_of_line 0) 1728 1))) 1729 1730 (goto_location (car f) (cadr f)) 1731 1732 (when (or (and (> dir 0) (or (< (car f) oy) (and (eq (car f) oy) (<= (cadr f) ox)))) 1733 (and (< dir 0) (or (> (car f) oy) (and (eq (car f) oy) (>= (cadr f) ox))))) 1734 (message "Search wrapped." 1)) 1735 1736 1)))) 1737 1738; Functions to delete text from the cursor to the next occurrence of a regular 1739; expression. 1740 1741(setq delete_rx_forw 1742 (lambda (repeat) 1743 (set_mark) 1744 (search 1 0 0 repeat) 1745 (clipboard_operation 1 0))) 1746 1747(setq delete_rx_back 1748 (lambda (repeat) 1749 (set_mark) 1750 (search -1 0 0 repeat) 1751 (clipboard_operation 1 0))) 1752 1753; Functions to delete sentences. 1754 1755(setq delete_sent_forw 1756 (lambda (repeat) 1757 (set_mark) 1758 (while (and repeat (find_pattern 1 sent_rx 1 0)) 1759 (dec repeat)) 1760 (clipboard_operation 1 0))) 1761 1762(setq delete_sent_back 1763 (lambda (repeat) 1764 (set_mark) 1765 (while (and repeat (find_pattern -1 sent_rx 1 0)) 1766 (dec repeat)) 1767 (clipboard_operation 1 0))) 1768 1769; Functions to delete paragraphs. 1770 1771(setq delete_para_back 1772 (lambda (repeat) 1773 (set_mark) 1774 (while (and repeat (find_pattern -1 para_rx 1 0)) 1775 (dec repeat)) 1776 (clipboard_operation 1 0))) 1777 1778(setq delete_para_forw 1779 (lambda (repeat) 1780 (set_mark) 1781 (while (and repeat (find_pattern 1 para_rx 1 0)) 1782 (dec repeat)) 1783 (clipboard_operation 1 0))) 1784 1785; Functions to delete text from cursor position to buffer endpoints. 1786 1787(setq delete_end_of_buffer 1788 (lambda (ignored) 1789 (set_mark) 1790 (end_of_buffer 0) 1791 (clipboard_operation 1 0))) 1792 1793(setq delete_start_of_buffer 1794 (lambda (ignored) 1795 (set_mark) 1796 (start_of_buffer 0) 1797 (clipboard_operation 1 0))) 1798 1799; Function to delete text to bookmarked line. 1800 1801(let ((tmp ())) 1802 1803 (setq delete_to_bookmark 1804 (lambda (ignored) 1805 (set_mark) 1806 (if (and (fixnump (setq tmp (goto_bookmark 1))) (> tmp 0)) 1807 (clipboard_operation 1 0) 1808 (setq mark ()))))) 1809 1810; Function to delete text from user-defined region. 1811 1812(setq delete_user_region 1813 (lambda (ignored) 1814 (if mark 1815 (clipboard_operation 1 0) 1816 (message "Mark unset." 1)))) 1817 1818; Function to insert clipboard content into buffer. 1819 1820(let ((limit 0) 1821 (line "") 1822 (leftover "") 1823 (last ()) 1824 (old_top 0) 1825 (insert_segment 0)) 1826 1827 (setq insert_segment 1828 (lambda (segment) 1829 (setq line (retrieve y)) 1830 (setq leftover 1) 1831 1832 (do_insert y (join "" (if x (substring line 0 x) "") 1833 segment 1834 (if (match term_rx segment) 1835 "" 1836 (setq leftover 0) 1837 (substring line x 0))) 1838 0) 1839 1840 (if (not leftover) 1841 (progn 1842 (setq x (+ x (length segment))) 1843 (add_offset) 1844 (compensate)) 1845 1846 (inc y) 1847 (when (< r limit) 1848 (inc r)) 1849 1850 (do_insert y (substring line x 0) -1) 1851 (setq x 0) 1852 (setq c 0) 1853 (setq base 0)))) 1854 1855 (setq paste 1856 (lambda (ignored) 1857 (catch 1858 (setq limit (- status_line 1)) 1859 1860 (unless (lastline) 1861 (do_insert 1 (char 10) 0)) 1862 1863 (switch clipboard) 1864 (setq last (lastline)) 1865 1866 (unless last 1867 (message "Clipboard is empty." 1) 1868 (switch current_buffer) 1869 (throw 1)) 1870 1871 (setq old_top (- y r)) 1872 (setq first_line y) 1873 (setq dirty 1) 1874 (setq mark (list y x)) 1875 1876 (message "Working..." 0) 1877 1878 (setq line (retrieve 1)) 1879 (switch current_buffer) 1880 (insert_segment line) 1881 1882 (if (and (eq last 1) (not (match term_rx line))) 1883 (progn 1884 (clearline r 0) 1885 (print (slice y base num_cols tab_stop 0)) 1886 (goto r c)) 1887 1888 (when (> (dec last) 1) 1889 (transfer clipboard 2 last current_buffer (- y 1)) 1890 (for (n y (+ y (- last 2))) (save_change "D" n undo)) 1891 (setq y (+ y (dec last))) 1892 (when (> (setq r (+ r last)) limit) 1893 (setq r limit)) 1894 (inc last)) 1895 1896 (when last 1897 (switch clipboard) 1898 (setq line (retrieve (inc last))) 1899 (switch current_buffer) 1900 (insert_segment line)) 1901 1902 (redisplay_after_paste first_line old_top)))))) 1903 1904(let ((top 0) 1905 (last 0) 1906 (row 0)) 1907 1908 (setq redisplay_after_paste 1909 (lambda (line old_top) 1910 (setq last (lastline)) 1911 (setq top (- y r)) 1912 1913 (when (> top old_top) 1914 (setq line top)) 1915 1916 (setq row (- line top)) 1917 1918 (while (< row status_line) 1919 (clearline row 0) 1920 (print (if (> line last) "~" (slice line base num_cols tab_stop 0))) 1921 (inc row) 1922 (inc line)) 1923 1924 (clearline status_line 0) 1925 (goto r c)))) 1926 1927; Core function to perform regular-expression-based substitutions. 1928 1929(let ((line "")) 1930 1931 (setq alter_region 1932 (lambda (first second rx replace repeat) 1933 (setq dirty 1) 1934 1935 (for (n (car first) (car second)) 1936 (setq line (retrieve n)) 1937 1938 (cond ((eq n (car first)) 1939 (if (eq (car first) (car second)) 1940 (do_insert n 1941 (join "" (if (cadr first) (substring line 0 (cadr first)) "") 1942 (substitute 1943 rx 1944 replace 1945 (substring line (cadr first) (- (cadr second) (cadr first))) 1946 repeat) 1947 (substring line (cadr second) 0)) 1948 0) 1949 1950 (do_insert n 1951 (join "" (if (cadr first) (substring line 0 (cadr first)) "") 1952 (substitute rx replace (chomp (substring line (cadr first) 0)) repeat) 1953 (char 10)) 1954 0))) 1955 1956 ((eq n (car second)) 1957 (do_insert n 1958 (join "" (if (cadr second) (substitute rx replace (substring line 0 (cadr second)) repeat) "") 1959 (substring line (cadr second) 0)) 1960 0)) 1961 1962 (1 (do_insert n (join "" (substitute rx replace (chomp line) repeat) (char 10)) 0))))))) 1963 1964; Function to get parameters from terminal for substitution operation. 1965 1966(let ((first ()) 1967 (second ()) 1968 (tmp ()) 1969 (pattern "") 1970 (rx "") 1971 (replace "") 1972 (repeat 0) 1973 (old ()) 1974 (replace_history ()) 1975 (pattern_history ())) 1976 1977 (setq substitute_with_params 1978 (lambda () 1979 (catch 1980 1981 ; Refuse to operate on an empty region. 1982 1983 (when (not (and mark (setq tmp (order_region (list y x) mark)))) 1984 (message "Nothing to alter." 1) 1985 (throw 1)) 1986 1987 (setq first (car tmp)) 1988 (setq second (cadr tmp)) 1989 1990 (setq old history) 1991 (setq history pattern_history) 1992 1993 (setq pattern (get_string "Pattern: " "" 0 1)) 1994 1995 (setq pattern_history history) 1996 (setq history old) 1997 1998 (unless pattern 1999 (display (- y r) base tab_stop) 2000 (goto_location (car first) (cadr first)) 2001 (throw 1)) 2002 2003 (when (stringp (setq rx (regcomp pattern))) 2004 (message rx 1) 2005 (display (- y r) base tab_stop) 2006 (goto_location (car first) (cadr first)) 2007 (throw 1)) 2008 2009 (clearline (- status_line 2) 0) 2010 (print "--") 2011 (clearline (- status_line 1) 0) 2012 (print "Pattern: " pattern) 2013 2014 (setq old history) 2015 (setq history replace_history) 2016 2017 (setq replace (get_string "Replacement: " "" 0 1 1)) 2018 2019 (setq replace_history history) 2020 (setq history old) 2021 2022 (unless (stringp replace) 2023 (display (- y r) base tab_stop) 2024 (goto_location (car first) (cadr first)) 2025 (throw 1)) 2026 2027 (clearline (- status_line 3) 0) 2028 (print "--") 2029 (clearline (- status_line 2) 0) 2030 (print "Pattern: " pattern) 2031 (clearline (- status_line 1) 0) 2032 (print "Replacement: " replace) 2033 2034 (when (< (setq repeat (get_number "Repeat: " "0" 1)) 0) 2035 (display (- y r) base tab_stop) 2036 (goto_location (car first) (cadr first)) 2037 (throw 1)) 2038 2039 (display (- y r) base tab_stop) 2040 (alter_region first second rx replace repeat) 2041 (redisplay_after_substitution first second)) 2042 2043 ; Clear the mark to prevent the user from accidentally accessing 2044 ; it. 2045 2046 (setq mark ())))) 2047 2048; Function update screen after a substitution operation. 2049 2050(let ((top 0) 2051 (row 0) 2052 (line 0)) 2053 2054 (setq redisplay_after_substitution 2055 (lambda (first second) 2056 (setq top (- y r)) 2057 2058 (if (> top (car first)) 2059 (progn 2060 (setq line top) 2061 (setq row 0)) 2062 2063 (setq line (car first)) 2064 (setq row (- (car first) top))) 2065 2066 (while (and (<= line (car second)) (< row status_line)) 2067 (clearline row 0) 2068 (print (slice line base num_cols tab_stop 0)) 2069 (inc row) 2070 (inc line)) 2071 2072 (goto_location (car first) (cadr first))))) 2073 2074; Wrapper functions for performing substitutions on lines and paragraphs. 2075 2076(setq substitute_end_of_line 2077 (lambda (ignored) 2078 (set_mark) 2079 (end_of_line 0) 2080 (substitute_with_params))) 2081 2082(setq substitute_start_of_line 2083 (lambda (ignored) 2084 (set_mark) 2085 (start_of_line 1) 2086 (substitute_with_params))) 2087 2088(setq substitute_para_forw 2089 (lambda (repeat) 2090 (set_mark) 2091 (forw_para repeat) 2092 (substitute_with_params))) 2093 2094(setq substitute_para_back 2095 (lambda (repeat) 2096 (set_mark) 2097 (back_para repeat) 2098 (substitute_with_params))) 2099 2100; Wrapper functions to perform substitutions on region from cursor position 2101; to the location of a bookmark, to one of the buffer endpoints, or to a 2102; match on a regular expression. 2103 2104(setq substitute_to_bookmark 2105 (lambda (ignored) 2106 (set_mark) 2107 (if (> (goto_bookmark 1) 0) 2108 (substitute_with_params) 2109 (setq mark ())))) 2110 2111(setq substitute_rx_forw 2112 (lambda (repeat) 2113 (set_mark) 2114 (search 1 0 0 repeat) 2115 (substitute_with_params))) 2116 2117(setq substitute_rx_back 2118 (lambda (repeat) 2119 (set_mark) 2120 (search -1 0 0 repeat) 2121 (substitute_with_params))) 2122 2123(setq substitute_end_of_buffer 2124 (lambda (ignored) 2125 (set_mark) 2126 (end_of_buffer 0) 2127 (substitute_with_params))) 2128 2129(setq substitute_start_of_buffer 2130 (lambda (ignored) 2131 (set_mark) 2132 (start_of_buffer 0) 2133 (substitute_with_params))) 2134 2135; Wrapper function to perform substitution on region. 2136 2137(setq substitute_user_region 2138 (lambda (ignored) 2139 (substitute_with_params))) 2140 2141; Function to allow user to set mark. 2142 2143(setq user_setmark 2144 (lambda (ignored) 2145 (set_mark) 2146 (message "Marked." 0))) 2147 2148; Function to write the region to a file. 2149 2150(let ((tmp ()) 2151 (file "") 2152 (first ()) 2153 (second ())) 2154 2155 (setq write_region 2156 (lambda (ignored) 2157 (catch 2158 (when (not mark) 2159 (message "Mark unset." 1) 2160 (throw 1)) 2161 2162 (when (or (not mark) (not (setq tmp (order_region (list y x) mark)))) 2163 (message "Nothing to write." 1) 2164 (throw 1)) 2165 2166 (setq first (car tmp)) 2167 (setq second (cadr tmp)) 2168 2169 (when (setq file (get_string "filename: " "" 1 1)) 2170 (if (stringp (setq tmp (write (car first) (car second) file 1 0))) 2171 (message tmp 1) 2172 (message (stringify tmp " lines.") 0))))))) 2173 2174; Function to insert a file into the buffer content after a specified line. 2175 2176(let ((file "") 2177 (not_empty 0) 2178 (c "") 2179 (tmp "")) 2180 2181 (setq insert_file 2182 (lambda (ignored) 2183 (when (setq file (get_string "file: " "" 1 1)) 2184 2185 (setq not_empty (lastline)) 2186 (setq c (substring file 0 1)) 2187 2188 (cond ((not not_empty) (setq tmp (read 0 file))) 2189 2190 ((eq y 1) 2191 (clearline status_line 0) 2192 (print "Before or after current line? (b/a) ") 2193 (print (char (setq tmp (get_char)))) 2194 2195 (cond ((eq tmp 97) (setq tmp (read 1 file))) 2196 ((eq tmp 98) (setq tmp (read 0 file)) (setq not_empty 0)) 2197 (1 (message "Not understood." 1) 2198 (setq tmp 0)))) 2199 2200 (1 (setq tmp (read y file)))) 2201 2202 (cond ((eq -1 tmp) (message "No such file." 1)) 2203 ((eq -2 tmp) (message "Permission denied." 1)) 2204 2205 ((stringp tmp) (message tmp 1)) 2206 2207 ((fixnump tmp) 2208 2209 (let ((first (if not_empty (+ y 1) 1)) 2210 (last (if not_empty (+ y tmp) tmp))) 2211 2212 (insert last (concat (chomp (retrieve last)) (char 10)) 0) 2213 2214 (for (n first last ) (save_change "D" n undo))) 2215 2216 (setq dirty 1) 2217 2218 (display (- y r) base tab_stop) 2219 (goto_location (if not_empty (+ y tmp) tmp) 0) 2220 2221 (message (stringify tmp " lines.") 0))))))) 2222 2223; Functions modifying the indentation of lines, with functions for 2224; formatting paragraphs and the function to change the value of the tab_stop 2225; variable, all together in a shared closure so that changes to the tab_stop 2226; variable may be propagated to local variables used these functions. 2227 2228(letn ((cmd1 (join "/" (libdir) (stringify "fmt.munger -l" line_length " -t" tab_stop))) 2229 (cmd2 (stringify cmd1 " -p"))) 2230 2231 (let ((first ()) 2232 (second ()) 2233 (filter_history ()) 2234 (old ()) 2235 (tmp "") 2236 (cmd "")) 2237 2238 (setq filter_region 2239 (lambda (ignored (program)) 2240 (catch 2241 (when (not mark) 2242 (message "mark unset." 1) 2243 (throw 1)) 2244 2245 (unless (and (lastline) mark (setq tmp (order_region (list y x) mark))) 2246 (message "Nothing to filter." 1) 2247 (throw 1)) 2248 2249 (setq first (car tmp)) 2250 (setq second (cadr tmp)) 2251 2252 (setq old history) 2253 (setq history filter_history) 2254 2255 (setq cmd (if program (car program) (get_string "Program: " "" 1 1))) 2256 2257 (setq filter_history history) 2258 (setq history old) 2259 2260 (unless cmd 2261 (throw 1)) 2262 2263 (for (n (car second) (car first)) 2264 (save_change "I" n undo)) 2265 2266 (setq dirty 1) 2267 (setq tmp (filter (car first) (car second) cmd)) 2268 2269 (if tmp 2270 (for (n (car first) (+ (car first) (- tmp 1))) 2271 (save_change "D" n undo)) 2272 2273 (switch undo) 2274 (for (n (car first) (car second)) 2275 (delete (lastline))) 2276 (switch current_buffer)) 2277 2278 (goto_location (car first) 0) 2279 (display (- y r) base tab_stop) 2280 (message (stringify tmp " lines.") 0))))) 2281 2282 (setq format_para_forw 2283 (lambda (repeat) 2284 (set_mark) 2285 (forw_para repeat) 2286 (when (not (eq y (lastline))) 2287 (back_line 1)) 2288 (filter_region 0 cmd1))) 2289 2290 (setq format_para_back 2291 (lambda (repeat) 2292 (set_mark) 2293 (back_para repeat) 2294 (when (not (eq 1 y)) 2295 (forw_line 1)) 2296 (filter_region 0 cmd1))) 2297 2298 (setq format_para_prefix_forw 2299 (lambda (repeat) 2300 (set_mark) 2301 (forw_para repeat) 2302 (when (not (eq y (lastline))) 2303 (back_line 1)) 2304 (filter_region 0 cmd2))) 2305 2306 (setq format_para_prefix_back 2307 (lambda (repeat) 2308 (set_mark) 2309 (back_para repeat) 2310 (when (not (eq y 1)) 2311 (forw_line 1)) 2312 (filter_region 0 cmd2))) 2313 2314 (let ((left_rx (regcomp (stringify "^(\t|\b{1," tab_stop "})"))) 2315 (right_rx (regcomp "^[\b\t]*[^\b\t]")) 2316 (right_replace "\t\&") 2317 (left_replace "") 2318 (tmp ()) 2319 (rx "") 2320 (replace "") 2321 (first ()) 2322 (second ())) 2323 2324 (setq set_line_length_wrapper 2325 (lambda (ignored) 2326 (set_line_length))) 2327 2328 (setq set_tab_stop_wrapper 2329 (lambda (ignored) 2330 (set_tab_stop))) 2331 2332 (setq set_line_length 2333 (lambda ((provided)) 2334 (catch 2335 (if (and (not provided) (setq tmp (get_number "Line length: " line_length))) 2336 (if (> tmp 0) (setq line_length tmp) (throw 0)) 2337 (setq line_length (car provided))) 2338 2339 (setq cmd1 (join "/" (libdir) (stringify "fmt.munger -l" line_length " -t" tab_stop))) 2340 (setq cmd2 (stringify cmd1 " -p")) 2341 2342 (when (lastline) 2343 (display (- y r) base tab_stop) 2344 (goto r c)) 2345 (message (stringify "line length = " line_length) 0)))) 2346 2347 ; Function to set the value of the tab_stop variable. 2348 2349 (setq set_tab_stop 2350 (lambda ((provided)) 2351 (catch 2352 (if (and (not provided) (setq tmp (get_number "Tabstop frequency: " tab_stop))) 2353 (if (> tmp 0) (setq tab_stop tmp) (throw 0)) 2354 (setq tab_stop (car provided))) 2355 2356 (setq left_rx (regcomp (stringify "^(\t|\b{1," tab_stop "})"))) 2357 (setq cmd1 (join "/" (libdir) (stringify "fmt.munger -l" line_length " -t" tab_stop))) 2358 (setq cmd2 (stringify cmd1 " -p")) 2359 2360 (when (lastline) 2361 (display (- y r) base tab_stop) 2362 (start_of_text 1)) 2363 (message (stringify "tab_stop = " tab_stop) 0)))) 2364 2365 ; Core function to modify the indentation of lines. 2366 2367 (setq shift_operation 2368 (lambda (left) 2369 (if (or (not (lastline)) (not mark) (not (setq tmp (order_region (list y x) mark)))) 2370 (message "Nothing to shift." 1) 2371 2372 (setq first (car tmp)) 2373 (setq second (cadr tmp)) 2374 2375 (setq rx (if left left_rx right_rx)) 2376 (setq replace (if left left_replace right_replace)) 2377 2378 (for (n (car first) (car second)) 2379 (do_insert n (substitute rx replace (retrieve n)) 0)) 2380 2381 (when (>= (car first) (- y r)) 2382 (display (- y r) base tab_stop)) 2383 2384 (setq mark ()) 2385 (setq dirty 1) 2386 2387 (goto_location (car first) 0) 2388 (start_of_text 1)))))) 2389 2390; Functions to shift lines. 2391 2392(setq shift_line_right 2393 (lambda (repeat) 2394 (set_mark) 2395 (if (eq repeat 1) 2396 (progn 2397 (end_of_line 1) 2398 (when (eq (cadr mark) x) 2399 (start_of_line 1))) 2400 (forw_line (dec repeat))) 2401 (shift_operation 0))) 2402 2403(setq shift_line_left 2404 (lambda (repeat) 2405 (set_mark) 2406 (if (eq repeat 1) 2407 (progn 2408 (end_of_line 1) 2409 (when (eq (cadr mark) x) 2410 (start_of_line 1))) 2411 (forw_line (dec repeat))) 2412 (shift_operation 1))) 2413 2414; Functions to shift paragraphs. 2415 2416(setq shift_para_right_forw 2417 (lambda (repeat) 2418 (set_mark) 2419 (forw_para repeat) 2420 (shift_operation 0))) 2421 2422(setq shift_para_left_forw 2423 (lambda (repeat) 2424 (set_mark) 2425 (forw_para repeat) 2426 (shift_operation 1))) 2427 2428(setq shift_para_right_back 2429 (lambda (repeat) 2430 (set_mark) 2431 (back_para repeat) 2432 (shift_operation 0))) 2433 2434(setq shift_para_left_back 2435 (lambda (repeat) 2436 (set_mark) 2437 (back_para repeat) 2438 (shift_operation 1))) 2439 2440; Functions to shift a region of lines from the cursor position to the next 2441; line containing a match on a regular expression. 2442 2443(setq shift_rx_left_forw 2444 (lambda (repeat) 2445 (set_mark) 2446 (when (search 1 0 0 repeat) 2447 (shift_operation 1)))) 2448 2449(setq shift_rx_left_back 2450 (lambda (repeat) 2451 (set_mark) 2452 (when (search -1 0 0 repeat) 2453 (shift_operation 1)))) 2454 2455(setq shift_rx_right_forw 2456 (lambda (repeat) 2457 (set_mark) 2458 (when (search 1 0 0 repeat) 2459 (shift_operation 0)))) 2460 2461(setq shift_rx_right_back 2462 (lambda (repeat) 2463 (set_mark) 2464 (when (search -1 0 0 repeat) 2465 (shift_operation 0)))) 2466 2467; Functions to shift the region. 2468 2469(setq shift_region_right 2470 (lambda (ignored) 2471 (shift_region 0))) 2472 2473(setq shift_region_left 2474 (lambda (ignored) 2475 (shift_region 1))) 2476 2477(setq shift_region 2478 (lambda (left) 2479 2480 (let ((saved_mark (and mark (car mark))) 2481 (saved_y y)) 2482 2483 (shift_operation left) 2484 (when saved_mark 2485 (setq mark (list saved_y 0)) 2486 (goto_location saved_mark 0) 2487 (start_of_text 1))))) 2488 2489; Functions to shift a region delimited by parentheses, brackets, or braces. 2490 2491(setq shift_delim_left 2492 (lambda (ignored) 2493 (set_mark) 2494 (when (jump_to_other_end 0) 2495 (shift_operation 1)))) 2496 2497(setq shift_delim_right 2498 (lambda (ignored) 2499 (set_mark) 2500 (when (jump_to_other_end 0) 2501 (shift_operation 0)))) 2502 2503; Functions to find and display matching delimiters. 2504 2505(setq jump_to_other_end 2506 (lambda (ignored) 2507 (hide) 2508 2509 (let ((ch (slice y x 1 1 0))) 2510 2511 (cond ((eq ch "[") 2512 (find_delim ch 1 bracket_rx y x 0 2513 (find 1 y x func_rx 0) > 1)) 2514 2515 ((eq ch "(") 2516 (find_delim ch 1 paren_rx y x 0 2517 (find 1 y x func_rx 0) > 1)) 2518 2519 ((eq ch "{") 2520 (find_delim ch 1 brace_rx y x 0 2521 (find 1 y x func_rx 0) > 1)) 2522 2523 ((eq ch "]") 2524 (find_delim ch -1 bracket_rx y x 0 2525 (find -1 y x func_rx 0) < 1)) 2526 2527 ((eq ch ")") 2528 (find_delim ch -1 paren_rx y x 0 2529 (find -1 y x func_rx 0) < 1)) 2530 2531 ((eq ch "}") 2532 (find_delim ch -1 brace_rx y x 0 2533 (find -1 y x func_rx 0) < 1)) 2534 2535 (1 (message "Not a delimiter." 1) 2536 0))) 2537 2538 (show))) 2539 2540; Shows location of matching opening delimiters as the corresponding 2541; closing delimiters are input. These delimiter pairs are recognized: 2542; ( ) [ ] { }. 2543 2544(setq showmatch 2545 (lambda (ch) 2546 (cond ((eq ch 41) 2547 (find_delim ")" -1 paren_rx y (- x 1) 0 2548 (find -1 y x func_rx 0) < 0)) 2549 2550 ((eq ch 93) 2551 (find_delim "]" -1 bracket_rx y (- x 1) 0 2552 (find -1 y x func_rx 0) < 0)) 2553 2554 ((eq ch 125) 2555 (find_delim "}" -1 brace_rx y (- x 1) 0 2556 (find -1 y x func_rx 0) < 0))))) 2557 2558; Does the actual searching for delimiters. 2559 2560(let ((f ())) 2561 2562 (setq find_delim 2563 (lambda (ch d rx ny nx s l p j) 2564 2565 (setq f (find d ny nx rx 0)) 2566 2567 (when (and (eq d 1) (not (car l))) 2568 (setq l (list (lastline) 0))) 2569 2570 (catch 2571 (while (car f) 2572 2573 (cond ((eq (slice (car f) (cadr f) 1 1 0) ch) 2574 (setq ny (car f)) 2575 (setq nx (cadr f)) 2576 (inc s) 2577 (setq f (find d ny nx rx 0)) 2578 (when (p (car f) (car l)) 2579 (throw (setq f (list 0 0))))) 2580 2581 (s 2582 (setq ny (car f)) 2583 (setq nx (cadr f)) 2584 (dec s) 2585 (setq f (find d ny nx rx 0)) 2586 (when (p (car f) (car l)) 2587 (throw (setq f (list 0 0))))) 2588 2589 (1 (throw f))))) 2590 2591 (if (not (car f)) 2592 (message "No match" 1) 2593 2594 (if j 2595 (goto_location (car f) (cadr f)) 2596 2597 (let ((off (and (cadr f) (cadr (slice (car f) 0 (cadr f) tab_stop 1))))) 2598 2599 (setq nx (+ off (cadr f))) 2600 (when (and (>= (car f) (- y r)) 2601 (>= nx base) 2602 (< nx (+ base num_cols))) 2603 2604 (goto (- (car f) (- y r)) (- nx base)) 2605 (pause 200000) 2606 (goto r c)))))))) 2607 2608; Functions to change the capitalization of words. 2609 2610(setq capitalize_word 2611 (lambda (repeat) 2612 (while repeat 2613 (change_case 1 0) 2614 (dec repeat)))) 2615 2616(setq uppercase_word 2617 (lambda (repeat) 2618 (while repeat 2619 (change_case 1 1) 2620 (dec repeat)))) 2621 2622(setq lowercase_word 2623 (lambda (repeat) 2624 (while repeat 2625 (change_case 0 1) 2626 (dec repeat)))) 2627 2628(let ((line "") 2629 (word "") 2630 (before "") 2631 (after "")) 2632 2633 (setq change_case 2634 (lambda (up all) 2635 2636 (catch 2637 (when (eq " " (slice y (+ base c) 1 tab_stop 0)) 2638 (forw_word 1)) 2639 2640 (set_mark) 2641 (forw_word 1) 2642 2643 (while (not (eq y (car mark))) 2644 (back_line 1) 2645 (end_of_line 1)) 2646 2647 (when (eq x (cadr mark)) 2648 (throw 0)) 2649 2650 (setq line (retrieve y)) 2651 (setq before (if (cadr mark) (substring line 0 (cadr mark)) "")) 2652 (setq word (substring line (cadr mark) (- x (cadr mark)))) 2653 (setq after (substring line x 0)) 2654 2655 (setq dirty 1) 2656 2657 (if up 2658 (if all 2659 (setq word (upcase word all)) 2660 (setq word (upcase (downcase word 1) all))) 2661 (setq word (downcase word all))) 2662 2663 (do_insert y (join word before after) 0) 2664 (clearline r 0) 2665 (print (chomp (slice y base num_cols tab_stop 0))) 2666 (goto r c))))) 2667 2668; Function to suspend the interpreter. 2669 2670(setq suspend_editor 2671 (lambda (ignored) 2672 (clearline status_line 0) 2673 (canon) 2674 (suspend) 2675 (nocanon) 2676 2677 (let ((diff (- num_lines (lines)))) 2678 (setq num_lines (lines)) 2679 (setq status_line (- num_lines 1)) 2680 (setq num_cols (cols)) 2681 2682 (setq x 0) 2683 (setq c 0) 2684 (setq base 0) 2685 (setq goal 0) 2686 2687 (when (>= r status_line) 2688 (when (< (setq r (- r diff)) 0) 2689 (setq r 0)))) 2690 2691 (display (if (lastline) (- y r) 0) 0 tab_stop) 2692 (clearline status_line 0) 2693 (goto r c))) 2694 2695; Function to pass a command to the shell. 2696 2697(let ((cmd "") 2698 (old ()) 2699 (cmd_history ())) 2700 2701 (setq shell_cmd 2702 (lambda (ignored) 2703 (setq old history) 2704 (setq history cmd_history) 2705 2706 (setq cmd (get_string "Command: " "" 1 1)) 2707 2708 (setq cmd_history history) 2709 (setq history old) 2710 2711 (when cmd 2712 (clearscreen) 2713 (canon) 2714 (system cmd) 2715 2716 (newline) 2717 (print "Any key to continue...") 2718 (nocanon) 2719 (get_char) 2720 2721 (let ((diff (- num_lines (lines)))) 2722 (setq num_lines (lines)) 2723 (setq status_line (- num_lines 1)) 2724 (setq num_cols (cols)) 2725 2726 (when (>= r status_line) 2727 (setq r (- r diff)))) 2728 2729 (display (if (lastline) (- y r) 0) base tab_stop) 2730 (clearline status_line 0) 2731 (goto r c))))) 2732 2733; Functions to toggle the state of the auto_wrap and auto_indent variables. 2734 2735(setq toggle_auto_wrap 2736 (lambda ((ignored)) 2737 (setq auto_wrap (and (or auto_wrap 1) (not (and auto_wrap 1)))) 2738 (message (stringify "auto_wrap " (if auto_wrap "on" "off")) 0))) 2739 2740(setq toggle_auto_indent 2741 (lambda ((ignored)) 2742 (setq auto_indent (and (or auto_indent 1) (not (and auto_indent 1)))) 2743 (message (stringify "auto_indent " (if auto_indent "on" "off")) 0))) 2744 2745(setq toggle_show_match 2746 (lambda ((ignored)) 2747 (setq show_match (and (or show_match 1) (not (and show_match 1)))) 2748 (message (stringify "show_match " (if show_match "on" "off")) 0))) 2749 2750; Function to display the settings of the user-modifiable variables. 2751 2752(let ((on 0) 2753 (off 0) 2754 (col 0) 2755 (top 0) 2756 (config 0) 2757 (len 0)) 2758 2759 (setq show_config 2760 (lambda (ignored) 2761 (setq on "on") 2762 (setq off "off") 2763 (setq col " columns") 2764 (setq top "--") 2765 2766 (setq config (list (stringify "tab_stop: every " tab_stop col) 2767 (stringify "auto_indent: " (if auto_indent on off)) 2768 (stringify "auto_wrap: " (if auto_wrap on off)) 2769 (stringify "show_match: " (if show_match on off)) 2770 (stringify "line_length: " line_length col) 2771 top)) 2772 2773 (setq len (length config)) 2774 2775 (if (< len status_line) 2776 (inc len) 2777 (setq len status_line) 2778 (setq top "- list truncated -")) 2779 2780 (clearline (- status_line len) 0) 2781 (print top) 2782 (dec len) 2783 2784 (while len 2785 (clearline (- status_line len) 0) 2786 (print (car config)) 2787 (dec len) 2788 (setq config (cdr config))) 2789 2790 (clearline status_line 0) 2791 (print "Any key to continue...") 2792 (get_char) 2793 (display (if (lastline) (- y r)) base tab_stop) 2794 (clearline status_line 0) 2795 (goto r c)))) 2796 2797; Function to insert a blank line before the cursor position. 2798 2799(let ((m ())) 2800 2801 (setq insert_blank_line 2802 (lambda (repeat) 2803 (while repeat 2804 (when (not (lastline)) 2805 (do_insert y (char 10) 0)) 2806 2807 (if (and auto_indent (setq m (matches leading_whitespace_rx (retrieve y)))) 2808 (do_insert y (stringify (car m) (char 10)) -1) 2809 (do_insert y (char 10) -1)) 2810 2811 (dec repeat)) 2812 2813 (setq dirty 1) 2814 (display (- y r) base tab_stop) 2815 (end_of_line 1)))) 2816 2817; Function to insert the output of a shell command into the buffer. 2818 2819(let ((cmd "") 2820 (cmd_history ()) 2821 (new 0) 2822 (not_empty 0) 2823 (tmp ()) 2824 (old ())) 2825 2826 (setq insert_cmd_output 2827 (lambda (ignored) 2828 (setq old history) 2829 (setq history cmd_history) 2830 2831 (setq cmd (get_string "Command: " "" 1 1)) 2832 2833 (setq cmd_history history) 2834 (setq history old) 2835 2836 (when cmd 2837 (setq old (- y r)) 2838 (setq dirty 1) 2839 2840 (if (lastline) 2841 (progn 2842 (setq not_empty 1) 2843 (setq tmp (+ y (setq new (input y cmd))))) 2844 2845 (setq tmp (setq new (input 0 cmd))) 2846 (setq not_empty 0)) 2847 2848 ; Ensure last line input is terminated. 2849 2850 (if (not (and (> tmp 0) (> new 0))) 2851 (redisplay 0) 2852 2853 (insert tmp (concat (chomp (retrieve tmp)) (char 10)) 0) 2854 2855 (for (n (if not_empty (+ y 1) 1) tmp) 2856 (save_change "D" n undo)) 2857 2858 (if (>= (- tmp old) status_line) 2859 (goto_location tmp 0) 2860 2861 (display old base tab_stop) 2862 (setq y tmp) 2863 (setq r (- tmp old)) 2864 (setq x (setq c 0)) 2865 (goto r 0)) 2866 2867 (message (stringify new " lines.") 0))))) 2868 2869 ; Function to write a range of lines to the stdin of a shell command. 2870 2871 (setq output_to_cmd 2872 (lambda (ignored) 2873 (if (or (not (lastline)) (not mark) (not (setq tmp (order_region (list y x) mark)))) 2874 (message "Nothing to output." 1) 2875 2876 (setq old history) 2877 (setq history cmd_history) 2878 2879 (setq cmd (get_string "Command: " "" 1 1)) 2880 2881 (setq cmd_history history) 2882 (setq history old) 2883 2884 (when cmd 2885 (clearscreen) 2886 (canon) 2887 (setq cmd (output (caar tmp) (car (cadr tmp)) cmd)) 2888 (newline) 2889 (print "Any key to continue...") 2890 (nocanon) 2891 (get_char) 2892 (display (- y r) base tab_stop) 2893 (clearline status_line 0) 2894 (goto r c) 2895 (message (stringify cmd " lines.") 0)))))) 2896 2897; Function to push the current clipboard onto the clipboard stack, and 2898; create a new clipboard. 2899 2900(setq push_clipboard 2901 (lambda (ignored) 2902 (switch clipboard) 2903 (if (not (lastline)) 2904 (progn 2905 (switch current_buffer) 2906 (message "Clipboard is empty. Not saved." 1)) 2907 2908 (push clipboard_stack clipboard) 2909 (setq clipboard (open)) 2910 (switch current_buffer) 2911 (message "Clipboard saved." 0)))) 2912 2913; Function to replace the current clipboard with one from the top of 2914; the clipboard stack. 2915 2916(setq pop_clipboard 2917 (lambda (ignored) 2918 (if (not (used clipboard_stack)) 2919 (progn 2920 (message "No saved clipboards." 1) 2921 0) 2922 2923 (switch clipboard) 2924 (close) 2925 (setq clipboard (pop clipboard_stack)) 2926 (switch current_buffer) 2927 (message "Clipboard restored." 0) 2928 1))) 2929 2930; Function to delete the region, unshift the current clipboard onto the 2931; bottom of the clipboard stack, and pop the top clipboard as the new 2932; current clipboard, then paste the content. 2933 2934(setq delete_rotate_and_paste 2935 (lambda (ignored) 2936 (if (not (used clipboard_stack)) 2937 (message "No saved clipboards." 1) 2938 2939 (delete_user_region ignored) 2940 (unshift clipboard_stack clipboard) 2941 (setq clipboard (pop clipboard_stack)) 2942 (paste ignored)))) 2943 2944; Function to pop the clipboard stack and paste the new content 2945; from the current clipboard. 2946 2947(setq pop_and_paste 2948 (lambda (ignored) 2949 (when (pop_clipboard ignored) 2950 (paste ignored)))) 2951 2952; Function to transfer the content of the clipboard on the top of 2953; the clipboard stack, to the current clipboard, and then paste it. 2954 2955(let ((top 0)) 2956 (setq transfer_clipboard 2957 (lambda (ignored) 2958 (if (not (used clipboard_stack)) 2959 (message "No saved clipboard." 1) 2960 2961 (switch clipboard) 2962 (empty) 2963 2964 (setq top (index clipboard_stack (topidx clipboard_stack))) 2965 (switch top) 2966 (transfer top 1 (lastline) clipboard 0) 2967 (switch current_buffer) 2968 (paste ignored))))) 2969 2970; Function to paste item from user-specified clipboard on clipboard 2971; stack. 2972 2973(let ((cb 0) 2974 (tc 0)) 2975 2976 (setq paste_clipboard 2977 (lambda (ignored) 2978 (if (not (setq tc (used clipboard_stack))) 2979 (message "No saved clipboards." 1) 2980 2981 (when (>= (setq cb (get_number "Clipboard: " 1 1)) 0) 2982 (if (> cb tc) 2983 (message (stringify "Only " tc " clipboards saved.") 1) 2984 2985 (if (not cb) 2986 (message (stringify tc " clipboards saved.") 0) 2987 2988 (dynamic_let (clipboard (index clipboard_stack (- cb 1))) 2989 (paste 1))))))))) 2990 2991; Function to exchange the position of the cursor and the mark. 2992 2993(let ((new_y 0) 2994 (new_x 0)) 2995 2996 (setq exchange_point_mark 2997 (lambda (ignored) 2998 (if (not mark) 2999 (message "Mark is unset." 1) 3000 3001 (setq new_y (car mark)) 3002 (setq new_x (cadr mark)) 3003 (setq mark (list y x)) 3004 (goto_location new_y new_x))))) 3005 3006; Function to list the filenames on the file stack. 3007 3008(let ((len 0) 3009 (items ()) 3010 (top "")) 3011 3012 (setq show_file_stack 3013 (lambda (ignored) 3014 (setq items (reverse (flatten file_stack))) 3015 (setq len (length items)) 3016 (setq top "--") 3017 3018 (if (< len status_line) 3019 (inc len) 3020 (setq len status_line) 3021 (setq top "- list truncated -")) 3022 3023 (clearline (- status_line len) 0) 3024 (print top) 3025 (dec len) 3026 3027 (while len 3028 (clearline (- status_line len) 0) 3029 (print (basename (caar items))) 3030 (dec len) 3031 (setq items (cdr items))) 3032 3033 (clearline status_line 0) 3034 (print "Any key to continue...") 3035 (get_char) 3036 (display (if (lastline) (- y r)) base tab_stop) 3037 (clearline status_line 0) 3038 (goto r c)))) 3039 3040; Functions to save file and cursor location before loading new file. 3041 3042(setq push_and_load 3043 (lambda (ignored (rotate)) 3044 (if (not filename) 3045 (progn 3046 (message "No filename associated with buffer." 1) 3047 0) 3048 3049 (push file_stack (list filename y x)) 3050 (unless rotate 3051 (unless (load_file 0) 3052 (pop file_stack))) 3053 3054 1))) 3055 3056; Function to rotate file stack, pushing currently-loaded file, and loading 3057; bottom item, shifting it off the stack. 3058 3059(setq rotate_file_stack 3060 (lambda (ignored) 3061 (if (not (used file_stack)) 3062 (message "No saved files." 1) 3063 3064 (when (push_and_load 0 1) 3065 (push file_stack (shift file_stack)) 3066 (pop_and_load 1))))) 3067 3068; Function to load buffer from file on top of file stack. 3069 3070(let ((tmp ())) 3071 3072 (setq pop_and_load 3073 (lambda (ignored) 3074 (catch 3075 (cond ((not (used file_stack)) 3076 (message "No saved files." 1) 3077 (throw 0)) 3078 3079 (dirty 3080 (message "Unsaved changes! Continue? (y/n) " 1) 3081 (goto status_line 34) 3082 (if (eq (get_char) 121) 3083 (setq dirty 0) 3084 3085 (clearline status_line 0) 3086 (goto r c) 3087 (throw 0)))) 3088 3089 (setq tmp (pop file_stack)) 3090 (when (not (eq filename (car tmp))) 3091 (load_file 0 (car tmp))) 3092 (when (lastline) 3093 (goto_location (cadr tmp) (car (cddr tmp)))))))) 3094 3095; Function to exchange the current file with the one on top of the file stack. 3096 3097(let ((top ())) 3098 3099 (setq switch_and_load 3100 (lambda (ignored) 3101 (if (not (used file_stack)) 3102 (message "No saved files." 1) 3103 3104 (if (not filename) 3105 (message "No filename associated with buffer." 1) 3106 3107 (setq top (list filename y x)) 3108 (when (pop_and_load 1) 3109 (push file_stack top))))))) 3110 3111; Functions to send lisp from the buffer to an inferior Munger for evaluation. 3112 3113(setq evaluate_lisp 3114 (lambda (ignored) 3115 (when (not (child_running)) 3116 (child_open "MUNGERPATH")) 3117 3118 (set_mark) 3119 (back_char 1) 3120 3121 (if (not (jump_to_other_end 0)) 3122 (forw_char 1) 3123 3124 (for (a y (car mark)) 3125 (cond ((eq a y) 3126 (child_write (slice a x 0 1 0))) 3127 3128 ((eq a (car mark)) 3129 (child_write (slice a 0 (cadr mark) 1 0))) 3130 3131 (1 (child_write (retrieve a))))) 3132 3133 (page_lisp) 3134 (jump_to_other_end 0) 3135 (forw_char 1)))) 3136 3137(setq get_more_lisp 3138 (lambda (ignored) 3139 (if (child_running) 3140 (page_lisp) 3141 (message "No inferior lisp is running." 1)))) 3142 3143(setq page_lisp 3144 (lambda () 3145 (let ((line "") 3146 (lns "") 3147 (len 0) 3148 (n 0) 3149 (top "--")) 3150 3151 (setq n 0) 3152 (while (and (< n 100) (child_running) (child_ready)) 3153 (setq line (child_read)) 3154 (setq lns (stringify lns line)) 3155 (inc n)) 3156 3157 (cond ((eq lns "") 3158 (if (not (child_running)) 3159 (message "Inferior lisp has exited." 1) 3160 (message "No output from inferior lisp." 1))) 3161 3162 (1 3163 (setq lns (split (stringify (char 10)) lns)) 3164 (setq len (length lns)) 3165 3166 (do 3167 (if (< len status_line) 3168 (inc len) 3169 (setq len status_line)) 3170 3171 (clearline (- status_line len) 0) 3172 (print top) 3173 (dec len) 3174 3175 (while len 3176 (clearline (- status_line len) 0) 3177 (print (car lns)) 3178 (dec len) 3179 (setq lns (cdr lns))) 3180 3181 (clearline status_line 0) 3182 (if (setq len (length lns)) 3183 (print "More...") 3184 (print "Any key to continue...")) 3185 (get_char) 3186 (clearline status_line 0) 3187 (display (- y r) base tab_stop) 3188 (goto r c) 3189 3190 len)))))) 3191 3192(setq close_lisp 3193 (lambda (ignored) 3194 (if (child_running) 3195 (progn 3196 (child_close) 3197 (message "Inferior lisp terminated." 0)) 3198 3199 (message "No inferior lisp is running." 1)))) 3200 3201; Function to redraw the screen, centering the current line. 3202 3203(setq redisplay 3204 (lambda (ignored) 3205 (if (< y (/ num_lines 2)) 3206 (setq r (- y 1)) 3207 (setq r (- (/ num_lines 2) 1))) 3208 3209 (display (if (lastline) (- y r) 0) base tab_stop) 3210 (goto r c))) 3211 3212; Function to scroll buffer up until current line is at top of screen. 3213 3214(setq reposition_high 3215 (lambda (ignored) 3216 (setq r 0) 3217 (display (- y r) base tab_stop) 3218 (goto r c))) 3219 3220; Function to scroll buffer down until current line is at bottom of screen. 3221 3222(setq reposition_low 3223 (lambda (ignored) 3224 (if (< y status_line) 3225 (setq r (- y 1)) 3226 (setq r (- num_lines 2))) 3227 3228 (display (- y r) base tab_stop) 3229 (goto r c))) 3230 3231; Function to describe cursor location on status line. 3232 3233(let ((last 0)) 3234 3235 (setq show_coordinates 3236 (lambda (ignored) 3237 (setq last (lastline)) 3238 (message (stringify (if filename (basename filename) "(no filename)") 3239 ": " y "." (+ base c) "/" last " " 3240 "(" (and last (/ (* y 100) last)) "%) " 3241 (if dirty "modified" "unmodified")) 3242 0)))) 3243 3244; Function to print message on status line. 3245 3246(setq message 3247 (lambda (msg bel) 3248 (clearline status_line 0) 3249 (print (and msg (substring msg 0 num_cols))) 3250 (when bel (beep)) 3251 (goto r c))) 3252 3253; Function to repaint the screen after a manual linebreak. 3254 3255(setq redisplay_after_linebreak 3256 (lambda () 3257 (setq x 0) 3258 (setq c 0) 3259 (setq goal 0) 3260 3261 (if base 3262 3263 ; If the screen was horizontally-scrolled, scroll back to column zero. 3264 3265 (progn 3266 (setq base 0) 3267 (clearline status_line 0) 3268 (display (- y r) base tab_stop) 3269 (forw_line 1)) 3270 3271 ; Otherwise, repaint only the affected lines. 3272 3273 (clearline r 0) 3274 (print (chomp (slice y base num_cols tab_stop 0))) 3275 (forw_line 1) 3276 (insertln) 3277 (print (chomp (slice y base num_cols tab_stop 0)))) 3278 3279 (clearline status_line 0) 3280 (goto r c))) 3281 3282; Function which inserts characters into the buffer. It handles manual and 3283; automatic linebreaks and auto_indenting. 3284 3285(let ((wrap_regexp (regcomp "^(.*[^\b\t])?[\b\t]+([^\b\t]+)?$")) 3286 (line 0) 3287 (before 0) 3288 (after 0) 3289 (m ())) 3290 3291 (setq insert_char 3292 (lambda (ch) 3293 3294 ; Mark the buffer dirty. 3295 3296 (setq dirty 1) 3297 3298 (if (not (lastline)) 3299 3300 ; Inserting into an empty buffer. 3301 3302 (if (or (eq ch 10) (eq ch 13)) 3303 (progn 3304 (do_insert y (char 10) 0) 3305 (do_insert y (char 10) 1) 3306 (clearline 0 0) 3307 (print " ") 3308 (forw_line 1)) 3309 3310 (do_insert y (concat (char ch) (char 10)) 0) 3311 (clearline r 0) 3312 (print (char ch)) 3313 (forw_char 1)) 3314 3315 ; Inserting into a non-empty buffer. Split the line up into before 3316 ; and after segments for further examination. 3317 3318 (setq line (retrieve y)) 3319 (setq before (stringify (if x (substring line 0 x) "") 3320 (if (eq ch 13) (char 10) (char ch)))) 3321 (setq after (substring line x 0)) 3322 (setq m ()) 3323 3324 (cond 3325 3326 ; Code to handle a manual linebreak. 3327 3328 ((or (eq ch 10) (eq ch 13)) 3329 3330 (if auto_indent 3331 (progn 3332 3333 ; If we're auto_indenting, prevent the creation of lines of 3334 ; only whitespace. 3335 3336 (if (match whitespace_rx (chomp before)) 3337 (do_insert y (char 10) 0) 3338 (do_insert y before 0)) 3339 3340 ; Propagate leading whitespace to new line. 3341 3342 (setq m (matches leading_whitespace_rx before)) 3343 (do_insert y (stringify (if m (car m) "") after) 1)) 3344 3345 (do_insert y before 0) 3346 (do_insert y after 1)) 3347 3348 ; Repaint altered screen lines, and move cursor to next line. 3349 3350 (redisplay_after_linebreak) 3351 3352 ; If autoidenting, move cursor past indentation. 3353 3354 (when (and auto_indent (setq m (if m (length (car m)) 0))) 3355 (while m 3356 (forw_char 1) 3357 (dec m)))) 3358 3359 ; Code to handle an automatic line break. 3360 3361 ((and auto_wrap 3362 (> (length (expand tab_stop before)) line_length) 3363 (setq m (matches wrap_regexp before))) 3364 3365 ; If we have found whitespace to break the line at, 3366 ; then break it, terminating the section before the cursor. 3367 3368 (do_insert y (stringify (cadr m) (char 10)) 0) 3369 (do_insert y (stringify (car (cddr m)) after) 1) 3370 3371 ; Repaint the altered lines and advance the cursor by one 3372 ; line. 3373 3374 (redisplay_after_linebreak) 3375 3376 ; If we broke the line before the cursor position on the 3377 ; old line, then we must advance the cursor past those 3378 ; characters, on the new line. 3379 3380 (setq m (length (car (cddr m)))) 3381 (while m 3382 (forw_char 1) 3383 (dec m))) 3384 3385 ; Ordinary character insertion. 3386 3387 (1 3388 (do_insert y (join "" before after) 0) 3389 (clearline r c) 3390 (print (chomp (slice y (+ base c) (- num_cols c) tab_stop 0))) 3391 (forw_char 1) 3392 (and show_match (showmatch ch)))))))) 3393 3394; Function to exit editor. 3395 3396(let ((len 0) 3397 (msg "")) 3398 3399 (setq terminate 3400 (lambda (ignored) 3401 (if dirty 3402 (progn 3403 (setq msg "Unsaved changes! Exit? (y/n)") 3404 (setq len (length msg)) 3405 (message msg 1) 3406 (goto status_line (+ len 1)) 3407 3408 (when (eq (get_char) 121) 3409 (print "y") 3410 (canon) 3411 (newline) 3412 (quit)) 3413 3414 (clearline status_line 0) 3415 (goto r c)) 3416 3417 (canon) 3418 (newline) 3419 (quit))))) 3420 3421; Function to save the buffer and exit. 3422 3423(setq save_and_exit 3424 (lambda (ignored) 3425 (catch 3426 (when dirty 3427 (unless (save_file 0) 3428 (throw 0))) 3429 (goto status_line 0) 3430 (canon) 3431 (newline) 3432 (quit)))) 3433 3434; Function to display version and copyright message. 3435 3436(let ((v (version))) 3437 (setq show_version 3438 (lambda (ignored) 3439 (message 3440 (stringify "Dickens " dkns_version 3441 " / Munger " (car v) "." (cadr v) 3442 " (c) 2005-19 James Bailie <jimmy@mammothcheese.ca>") 0)))) 3443 3444; Function to count the words in the buffer and display the count on the 3445; status line. 3446 3447(setq show_word_count 3448 (lambda (ignored) 3449 (message (stringify (words) " words.") 0))) 3450 3451; Functions to copy the lines onto the clipboard. 3452 3453(setq copy_line 3454 (lambda (repeat) 3455 (set_mark) 3456 (forw_line (dec repeat)) 3457 (end_of_line 1) 3458 (clipboard_operation 0 0) 3459 (exchange_point_mark 1) 3460 (setq mark ()))) 3461 3462(setq copy_para 3463 (lambda (repeat) 3464 (set_mark) 3465 (forw_para repeat) 3466 (clipboard_operation 0 0) 3467 (exchange_point_mark 1) 3468 (setq mark ()))) 3469 3470; Allows the insertion of any non-control character. 3471 3472(setq escape_insert_char 3473 (lambda (repeat) 3474 (message "Type character" 0) 3475 (while repeat 3476 (insert_char (get_char)) 3477 (dec repeat)) 3478 (message "" 0))) 3479 3480; Sets repeat count for next command. 3481 3482(setq get_repeat_count 3483 (lambda (ignored) 3484 (let ((cnt (get_number "Count: " ""))) 3485 (when (> cnt 0) 3486 (setq count cnt))))) 3487 3488; Function to drop down to the lisp prompt for debugging purposes. 3489 3490(setq debug 3491 (lambda (ignored) 3492 (canon) 3493 (newline) 3494 (interact) 3495 (nocanon) 3496 3497 (let ((diff (- num_lines (lines)))) 3498 (setq num_lines (lines)) 3499 (setq status_line (- num_lines 1)) 3500 (setq num_cols (cols)) 3501 3502 (when (>= r status_line) 3503 (setq r (- r diff)))) 3504 3505 (display (if (lastline) (- y r) 0) base tab_stop) 3506 (clearline status_line 0) 3507 (goto r c))) 3508 3509; Functions to work with tags. 3510 3511(let ((line "") 3512 (tmp ())) 3513 3514 (setq check_tags 3515 (lambda () 3516 (when (and (unless (exists "tags") (message "No tags file found." 1) "") 3517 (unless (access "tags" 0) (message "You do not have permission to read the tags file." 1) "") 3518 (or (not (keys tags)) 3519 (not (eq tags_mtime (car (cdddr (stat "tags"))))))) 3520 3521 (foreach (lambda (k) (unhash tags k)) (keys tags)) 3522 3523 (with_input_file "tags" 3524 (while (stringp (setq line (getline))) 3525 (setq tmp (split (char 9) (chomp line) 3)) 3526 3527 (when (< (length tmp) 3) 3528 (continue)) 3529 3530 (hash tags (if (and (eq (substring (car tmp) 0 1) "M") 3531 (cdr tmp) 3532 (eq (substring (car tmp) 1 0) (rootname (cadr tmp)))) 3533 "main" 3534 (car tmp)) 3535 3536 (list (cadr tmp) 3537 (regcomp (chop (chop (substring (car (cddr tmp)) 2 0))) 3538 1 1))))) 3539 3540 (setq tags_mtime (car (cdddr (stat "tags")))))))) 3541 3542(let ((word_rx (regcomp "^[A-Za-z_0-9]+"))) 3543 3544 (setq find_symbol_under_cursor 3545 (lambda () 3546 (if (not (lastline)) 3547 "" 3548 3549 (if (setq m (matches word_rx (slice y x 0 tab_stop 0))) 3550 (car m) 3551 ""))))) 3552 3553(let ((width 0) 3554 (len 0) 3555 (item "") 3556 (target "") 3557 (unformatted (stack)) 3558 (formatted (stack)) 3559 (column 0) 3560 (columns 0) 3561 (rows 0) 3562 (max 0) 3563 (tmp 0) 3564 (tmp2 0) 3565 (total 0)) 3566 3567 (setq format_possibilities 3568 (lambda (items) 3569 (when items 3570 (message "Working..." 0) 3571 3572 (assign unformatted items) 3573 (setq len (used unformatted)) 3574 (setq max (length (car items))) 3575 3576 (for (n 0 (topidx unformatted)) 3577 (when (> (setq tmp2 (length (index unformatted n))) max) 3578 (setq max tmp2))) 3579 3580 (inc max) 3581 (setq width (cols)) 3582 3583 (setq columns (or (/ (- width 1) max) 1)) 3584 (setq rows (/ (+ len columns) columns)) 3585 (setq total (* rows columns)) 3586 3587 (dec max) 3588 (clear formatted (used formatted)) 3589 (setq item "") 3590 3591 (for (n 0 total) 3592 (setq column (% n columns)) 3593 (setq target (+ (* column rows) (/ n columns))) 3594 3595 (when (< target len) 3596 (setq tmp (index unformatted target)) 3597 (if (< (setq tmp2 (length tmp)) max) 3598 (setq tmp2 (+ (- max tmp2) 1)) 3599 (setq tmp2 1)) 3600 3601 (setq item (join "" item (substring tmp 0 max))) 3602 3603 (while tmp2 3604 (setq item (join "" item " ")) 3605 (dec tmp2))) 3606 3607 (when (eq column (- columns 1)) 3608 (while (< (length item) width) 3609 (setq item (join "" item " "))) 3610 3611 (push formatted item) 3612 (setq item ""))) 3613 3614 (clear unformatted (used unformatted)) 3615 (flatten formatted))))) 3616 3617(let ((len 0) 3618 (symbols ()) 3619 (long "") 3620 (results ())) 3621 3622 (setq complete_tag 3623 (lambda (tag) 3624 (setq len (length tag)) 3625 (setq symbols (sortlist (keys tags))) 3626 (setq long tag) 3627 (setq results ()) 3628 3629 (if (or (not tag) (not tags)) 3630 (cons tag (format_possibilities symbols)) 3631 3632 (while symbols 3633 (when (eq (substring (car symbols) 0 len) tag) 3634 (setq results (cons (car symbols) results))) 3635 (setq symbols (cdr symbols))) 3636 3637 (cond ((eq (length results) 1) 3638 (setq long (car results)) 3639 (setq results ())) 3640 3641 ((eq results ()) 3642 (setq long tag)) 3643 3644 (1 (catch 3645 (while 1 3646 (setq symbols results) 3647 3648 (while symbols 3649 (when (not (cdr symbols)) 3650 (setq symbols (cdr symbols)) 3651 (continue)) 3652 3653 (when (or (<= (length (car symbols)) len) 3654 (<= (length (cadr symbols)) len)) 3655 (throw long)) 3656 3657 (when (not (eq (substring (car symbols) len 1) 3658 (substring (cadr symbols) len 1))) 3659 (throw long)) 3660 3661 (setq symbols (cdr symbols))) 3662 3663 (setq long (join "" long (substring (car results) len 1))) 3664 (inc len))))) 3665 3666 (cons long (and results (format_possibilities results))))))) 3667 3668(let ((tag ()) 3669 (init "") 3670 (old ()) 3671 (tmp "") 3672 (tag_history ())) 3673 3674 (setq goto_tag 3675 (lambda (ignored) 3676 (catch 3677 3678 (when (stringp (check_tags)) 3679 (throw 0)) 3680 3681 (setq old history) 3682 (setq history tag_history) 3683 3684 (setq init (find_symbol_under_cursor)) 3685 (set_complete_func complete_tag) 3686 (setq tag (get_string "Tag: " init 1 1)) 3687 (set_complete_func complete) 3688 3689 (setq tag_history history) 3690 (setq history old) 3691 3692 (when tag 3693 (if (not (setq tag (lookup tags tag))) 3694 (message "No such tag." 1) 3695 3696 (if (eq (basename filename) (car tag)) 3697 (push file_stack (list filename y x)) 3698 3699 (if (setq tmp (exists (car tag))) 3700 (cond ((eq tmp -1) 3701 (message (stringify "permission to access " (car tag) " denied") 1) 3702 (throw 0)) 3703 3704 ((not (eq tmp 1)) 3705 (message (stringify (car tag) " is a not a regular file") 1) 3706 (throw 0))) 3707 3708 (message (stringify (car tag) " does not exist") 1) 3709 (throw 0)) 3710 3711 (setq old (list filename y x)) 3712 3713 (unless (load_file 0 (car tag)) 3714 (throw 0)) 3715 3716 (when (car old) 3717 (push file_stack old))) 3718 3719 (when (find_pattern 1 (cadr tag) 0 1) 3720 (start_of_text 1)))))))) 3721 3722; Function to get a single character from the terminal. Resizes screen upon 3723; receipt of SIGWINCH. 3724 3725(let ((ch "") 3726 (recording 0) 3727 (pending ()) 3728 (macro_keys ())) 3729 3730 (setq toggle_recording 3731 (lambda (ignored) 3732 (if recording 3733 (progn 3734 (setq recording 0) 3735 (setq macro_keys (reverse (cddr macro_keys))) 3736 (message "Recording stopped." 0)) 3737 3738 (setq recording 1) 3739 (setq macro_keys ()) 3740 (message "Recording started." 0)))) 3741 3742 (setq play_macro 3743 (lambda (repeat) 3744 (cond (recording 3745 (message "Cannot play keystrokes while recording keystrokes." 1) 3746 (setq macro_keys (cdr macro_keys))) 3747 3748 (pending (message "Macro is already playing." 1)) 3749 3750 ((not macro_keys) (message "No keystrokes have been recorded." 1)) 3751 3752 (1 (let ((tmp ())) 3753 (while (> repeat 0) 3754 (setq tmp (append tmp macro_keys)) 3755 (dec repeat)) 3756 (setq pending tmp)))))) 3757 3758 (setq get_char 3759 (lambda ((win)) 3760 (cond (pending 3761 (setq ch (car pending)) 3762 (setq pending (cdr pending)) 3763 ch) 3764 3765 ((not (eq (setq ch (getchar)) -2)) 3766 (setq ch 3767 (case ch 3768 (13 10) 3769 (27 (+ (getchar) 128)) 3770 (-1 4) 3771 (? ch))) 3772 3773 (when recording 3774 (setq macro_keys (cons ch macro_keys))) 3775 3776 (when win 3777 (display (if (lastline) (- y r) 0) 0 tab_stop) 3778 (setq winch 1) 3779 (goto r c)) 3780 3781 ch) 3782 3783 (1 3784 (let ((diff (- num_lines (lines)))) 3785 (setq num_lines (lines)) 3786 (setq status_line (- num_lines 1)) 3787 (setq num_cols (cols)) 3788 3789 (setq x 0) 3790 (setq c 0) 3791 (setq base 0) 3792 (setq goal 0) 3793 3794 (when (>= r status_line) 3795 (when (< (setq r (- r diff)) 0) 3796 (setq r 0)))) 3797 3798 (tailcall get_char 1)))))) 3799 3800(let ((trailing_whitespace_rx (regcomp "[\b\t]+$")) 3801 (f ())) 3802 3803 (setq strip_whitespace 3804 (lambda (ignored) 3805 (setq f '(1 0 0)) 3806 3807 (while (car f) 3808 (insert (car f) 3809 (concat (substitute trailing_whitespace_rx 3810 "" 3811 (chomp (retrieve (car f))) 3812 1) 3813 (char 10)) 3814 0) 3815 (setq f (find 1 (car f) 0 trailing_whitespace_rx 0))) 3816 3817 (start_of_line 1) 3818 (setq dirty 1)))) 3819 3820; Tables mapping character codes to functions. 3821 3822(setq commands (table)) 3823(setq extended (table)) 3824 3825; Initial mappings for commands. 3826 3827(hash commands 24 1) ; C-x 3828(hash commands 7 0) ; C-g 3829 3830(hash commands 6 forw_char) ; C-f 3831(hash commands 2 back_char) ; C-b 3832 3833(hash commands 230 forw_word) ; M-f 3834(hash commands 226 back_word) ; M-b 3835 3836(hash commands 14 forw_line) ; C-n 3837(hash commands 16 back_line) ; C-p 3838 3839(hash commands 1 start_of_line) ; C-a 3840(hash commands 5 end_of_line) ; C-e 3841 3842(hash commands 22 forw_screen) ; C-v 3843(hash commands 246 back_screen) ; M-v 3844 3845(hash commands 238 forw_scroll) ; M-n 3846(hash commands 240 back_scroll) ; M-p 3847 3848(hash commands 20 reposition_high) ; C-t 3849(hash commands 3 reposition_low) ; C-c 3850 3851(hash commands 12 redisplay) ; C-l 3852(hash extended 103 show_coordinates) ; C-x g 3853 3854(hash extended 76 evaluate_lisp) ; C-x L 3855(hash extended 63 get_more_lisp) ; C-x ? 3856(hash extended 12 close_lisp) ; C-x C-l 3857 3858(hash extended 3 terminate) ; C-x C-c 3859(hash extended 61 delete_start_of_text) ; C-x = 3860 3861(hash commands 188 start_of_buffer) ; M-< 3862(hash commands 190 end_of_buffer) ; M-> 3863 3864(hash extended 6 load_file_wrapper) ; C-x C-f 3865(hash extended 35 goto_line_number) ; C-x # 3866 3867(hash extended 19 save_file) ; C-x C-s 3868(hash extended 70 set_filename) ; C-x F 3869 3870(hash extended 108 goto_middle) ; C-x l 3871 3872(hash commands 4 delete_char_forw) ; C-d 3873(hash commands 8 delete_char_back) ; C-h 3874 3875(hash commands 228 delete_word_forw) ; M-d 3876(hash commands 232 delete_word_back) ; M-h 3877 3878(hash commands 11 delete_end_of_line) ; C-k 3879(hash commands 235 delete_start_of_line) ; M-k 3880 3881(hash extended 48 high) ; C-x 0 3882(hash extended 49 low) ; C-x 1 3883 3884(hash extended 109 set_bookmark) ; C-x m 3885(hash extended 106 goto_bookmark) ; C-x j 3886 3887(hash commands 222 start_of_text) ; M-^ 3888(hash commands 171 forw_start_of_text) ; M-+ 3889(hash commands 173 back_start_of_text) ; M-- 3890 3891(hash commands 19 forw_search) ; C-s 3892(hash commands 18 back_search) ; C-r 3893 3894(hash commands 243 forw_search_again) ; M-s 3895(hash commands 242 back_search_again) ; M-r 3896 3897(hash commands 229 forw_sent) ; M-e 3898(hash commands 225 back_sent) ; M-a 3899 3900(hash commands 253 forw_para) ; M-} 3901(hash commands 251 back_para) ; M-{ 3902 3903(hash commands 221 forw_func) ; M-] 3904(hash commands 219 back_func) ; M-[ 3905 3906(hash extended 119 delete_rx_forw) ; C-x w 3907(hash extended 113 delete_rx_back) ; C-x q 3908 3909(hash extended 69 delete_sent_forw) ; C-x E 3910(hash extended 65 delete_sent_back) ; C-x A 3911 3912(hash extended 105 delete_para_forw) ; C-x i 3913(hash extended 111 delete_para_back) ; C-x o 3914 3915(hash extended 121 delete_end_of_buffer) ; C-x y 3916(hash extended 117 delete_start_of_buffer) ; C-x u 3917 3918(hash extended 75 delete_to_bookmark) ; C-x K 3919(hash commands 25 paste) ; C-y 3920(hash commands 249 delete_rotate_and_paste) ; M-y 3921 3922(hash extended 4 delete_user_region) ; C-x C-d 3923(hash commands 0 user_setmark) ; C-[space] 3924 3925(hash extended 116 substitute_end_of_line) ; C-x t 3926(hash extended 84 substitute_start_of_line) ; C-x T 3927 3928(hash extended 74 substitute_to_bookmark) ; C-x J 3929(hash extended 18 substitute_user_region) ; C-x C-r 3930 3931(hash extended 41 substitute_para_forw) ; C-x ) 3932(hash extended 40 substitute_para_back) ; C-x ( 3933 3934(hash extended 83 substitute_rx_forw) ; C-x S 3935(hash extended 82 substitute_rx_back) ; C-x R 3936 3937(hash extended 46 substitute_end_of_buffer) ; C-x . 3938(hash extended 44 substitute_start_of_buffer) ; C-x , 3939 3940(hash extended 87 write_region) ; C-x W 3941(hash extended 9 insert_file) ; C-x C-i 3942 3943(hash extended 13 filter_region) ; C-x C-m 3944 3945(hash commands 21 undo_change) ; C-u 3946(hash extended 95 redo_change) ; C-x _ 3947 3948(hash commands 250 shift_line_left) ; M-z 3949(hash commands 248 shift_line_right) ; M-x 3950 3951(hash extended 122 shift_para_left_forw) ; C-x z 3952(hash extended 120 shift_para_right_forw) ; C-x x 3953 3954(hash extended 26 shift_para_left_back) ; C-x C-z 3955(hash extended 24 shift_para_right_back) ; C-x C-x 3956 3957(hash extended 96 shift_rx_right_forw) ; C-x ` 3958(hash extended 126 shift_rx_right_back) ; C-x ~ 3959 3960(hash extended 124 shift_rx_left_back) ; C-x | 3961(hash extended 92 shift_rx_left_forw) ; C-x \ 3962 3963(hash commands 165 jump_to_other_end) ; M-% 3964 3965(hash commands 187 capitalize_word) ; M-; 3966(hash commands 162 lowercase_word) ; M-" 3967(hash commands 186 uppercase_word) ; M-: 3968 3969(hash extended 36 suspend_editor) ; C-x $ 3970(hash extended 33 shell_cmd) ; C-x ! 3971 3972(hash extended 85 toggle_auto_wrap) ; C-x U 3973(hash extended 73 toggle_auto_indent) ; C-x I 3974(hash extended 77 toggle_show_match) ; C-x M 3975 3976(hash extended 66 set_tab_stop_wrapper) ; C-x B 3977(hash extended 78 set_line_length_wrapper) ; C-x N 3978 3979(hash extended 64 show_config) ; C-x @ 3980(hash commands 15 insert_blank_line) ; C-o 3981 3982(hash commands 241 format_para_forw) ; M-q 3983(hash commands 247 format_para_back) ; M-w 3984 3985(hash commands 17 format_para_prefix_forw) ; C-q 3986(hash commands 23 format_para_prefix_back) ; C-w 3987 3988(hash extended 38 insert_cmd_output) ; C-x & 3989(hash extended 42 output_to_cmd) ; C-x * 3990 3991(hash commands 244 push_clipboard) ; M-t 3992(hash commands 231 pop_clipboard) ; M-g 3993 3994(hash extended 81 transfer_clipboard) ; C-x Q 3995(hash extended 59 paste_clipboard) ; C-x ; 3996(hash extended 241 pop_and_paste) ; C-x M-q 3997 3998(hash extended 67 copy_user_region) ; C-x C 3999(hash extended 5 exchange_point_mark) ; C-x C-e 4000 4001(hash extended 50 push_and_load) ; C-x 2 4002(hash extended 51 pop_and_load) ; C-x 3 4003(hash extended 68 rotate_file_stack) ; C-x D 4004 4005(hash extended 52 switch_and_load) ; C-x 4 4006(hash extended 57 save_and_exit) ; C-x 9 4007 4008(hash extended 53 shift_delim_left) ; C-x 5 4009(hash extended 54 shift_delim_right) ; C-x 6 4010 4011(hash extended 55 shift_region_left) ; C-x 7 4012(hash extended 56 shift_region_right) ; C-x 8 4013 4014(hash extended 86 show_version) ; C-x V 4015(hash extended 22 show_word_count) ; C-x C-v 4016 4017(hash extended 71 debug) ; C-x G 4018(hash extended 1 show_file_stack) ; C-x C-a 4019 4020(hash extended 7 goto_tag) ; C-x C-g 4021(hash extended 16 delete_whitespace) ; C-x C-p 4022 4023(hash extended 32 toggle_recording) ; C-x [space] 4024(hash commands 160 play_macro) ; M-[space] 4025 4026(hash commands 227 copy_line) ; M-c 4027(hash commands 195 copy_para) ; M-C 4028 4029(hash commands 233 escape_insert_char) ; M-i 4030(hash commands 239 get_repeat_count) ; M-o 4031 4032(hash extended 115 strip_whitespace) ; C-x s 4033 4034(setq dickens '( 4035 " _qWQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQ> ..:+{a...:::::" 4036 " _wWWWWQQQQQQQQQQQQQQQQQQQQQQQQQQQQQQmw, ._==;=:=Y+=..-:::" 4037 " .<SYn#mQWQQQQQQQQQQQQQQQWQQQQQQQQQQQQQm1o;. . -{i. ::::=: -:.:" 4038 " -::i|XWWWQQQQQQQQQQWQQQQQQQQWQQQQQQQQm>o; .. .- . =: ..::::" 4039 " ..::)SWWWQQQQQQQQQQQQQQQQQQWBVTVWWWQQQ%1 .... :-::-." 4040 " . .<XWQQQWQQWQWQQQQQQQQWWmwaaawmW#WWQwc --. .::.-::" 4041 " _s, .-?WBWBVY?Y!!YV$QQQQQQQW#RVQB$$mWWWWmc . .::;::::.." 4042 " :*\"+. .)!~-:=aaa>,:-3WQWQQ#Saas)nmmQWWQQQmc=_. .=:;:::.--:" 4043 " . . . . ..aQD$BVc: \"$QQQQQQWWQQQQWQQQQQQQwmg..::::::.:.::." 4044 " . .~-.:Symga,_]QQQQQQQQQQQQQQQQQQQQWQB(:==;:;::::-:." 4045 " . . .=dWWQQQQE>=XQQQQQQQQQQQQQQQQQQQQQQC=;==;;:::-:-:" 4046 " ......=uwmWWQW#c:.+WWQQQQQQQQQQQQQQQQQQQWe-;==;;:::-:.:" 4047 " ..=iowuwm#mWWWE+...3WQQQQQQQQQQQQQQQQQWV!:===;;;::::::-" 4048 " ..=|3W#mWWQWWh.::-~$WQQP?QWQQQQQQWQQQW; =;==::;:::::.:" 4049 "=_. ..:+{SXmWWWWX: . -+qgyWQQQQQQQQQQQW(:::=;;;:;:::-::" 4050 "inqas, .:=<IXXmmmX>. .]RVUWQQWWWWWBQWQQ[:;;=:;:;::::-:." 4051 "<XWWWQwc. ..:=|13XXXxi=,.=oc .-!YU#US*1#mWQQC;===;=;::::.:::" 4052 "=3#WWWWWgc. ...:-=-++++xuqc=o1>+ =a+---+)YXmQmw===:;:;:::-:::" 4053 " -3WWQQQWmw. . .... .--\"~^+YaawwmWQwc .==~3QQm}|l=:.:=::::::" 4054 " .]WWQQQQQWm, . .. .... ..-!??!<mWWQa. -{mQQQc<n2n;:-=+|=|=" 4055 " .mQQQQQQQQWz. . ..... ._.xmQWQQWWD` _mQQQQzio2Soa,. =iix" 4056 "_wQQQQQQQQQQQc ... . . ...:<#WBWWW#X(...jQQQQQc=nXXSXX>..:IS" 4057 "QQQQQQQQQQQQWk . . . ....+!{2YY*:-.. )WQQQQQF{XXS2X2q>..:{" 4058 "QQQQQQQQQWQQW( :: . ..==.|:.- .:==:-=+<mQQQQQ(xXXX2S2XX;..-")) 4059 4060; Load user start-up code. 4061 4062(let ((init (join "/" (getenv "HOME") ".dkns")) 4063 (tmp 0)) 4064 4065 (when (setq tmp (exists init)) 4066 (cond ((eq -1 tmp) (message "permission to read home directory denied" 1)) 4067 ((not (eq tmp 1)) (message "~/.dkns is not a regular file" 1)) 4068 ((not (access init 0)) (message "permission to read ~/.dkns denied" 1)) 4069 (1 (load init))))) 4070 4071; Process command-line arguments. 4072 4073(let ((start 1)) 4074 (next) 4075 4076 (catch 4077 (display 0 0 0) 4078 4079 (if (next) 4080 (progn 4081 (if (eq (substring (current) 0 1) "+") 4082 (if (< (length (current)) 2) 4083 (throw (message "Empty line number argument." 1)) 4084 4085 (setq start (or (digitize (substring (current) 1 0)) 1)) 4086 (if (not (next)) 4087 (throw (message "Line number argument present without filename argument." 1)) 4088 (load_file 0 (current)))) 4089 4090 (setq start 1) 4091 (load_file 1 (current))) 4092 4093 (while (next) 4094 (unshift file_stack (list (current) 1 0))) 4095 4096 (consolidate_history 1 "" (current)) 4097 (when (lastline) 4098 (goto_location start 0))) 4099 4100 ; Initial screen for an empty buffer. 4101 4102 (let ((x (/ (- num_cols (length (car dickens))) 2)) 4103 (y (/ (- (- num_lines 1) (length dickens)) 2)) 4104 (txt dickens)) 4105 4106 (when (< y 0) 4107 (setq y 0)) 4108 (when (< x 0) 4109 (setq x 0)) 4110 4111 (while (and (< y status_line) txt) 4112 (goto y x) 4113 (print (car txt)) 4114 (inc y) 4115 (setq txt (cdr txt)))) 4116 4117 (goto r c)))) 4118 4119 4120; Takes terminal device out of canonical mode. This used to be near the top of 4121; the script, but the Xterm on Xquartz will not reliably refresh the screen 4122; when the editor starts if (nocanon) occurs earlier in the script. Go figure. 4123 4124(nocanon) 4125 4126(let ((ch 0) 4127 (start 0) 4128 (local_count 0) 4129 (cmd "") 4130 (extended_cmd 0) 4131 (allow_on_empty 0)) 4132 4133 (let ((allowed (list terminate load_file_wrapper save_file set_filename insert_file 4134 suspend_editor shell_cmd toggle_auto_wrap toggle_auto_indent 4135 pop_clipboard transfer_clipboard pop_and_paste delete_rotate_and_paste 4136 toggle_show_match show_coordinates paste show_version 4137 set_tab_stop set_line_length show_config debug goto_tag 4138 insert_blank_line insert_cmd_output redo_change undo_change 4139 escape_insert_char switch_and_load push_and_load pop_and_load show_file_stack))) 4140 4141 (setq allow_on_empty 4142 (lambda (cmd) 4143 (if (member cmd allowed) 4144 1 4145 (message "Buffer is empty." 1) 4146 0)))) 4147 4148 ; Launches multi-key commands. 4149 4150 (setq extended_cmd 4151 (lambda () 4152 (message "C-x ?" 0) 4153 4154 (if (not (setq cmd (lookup extended (setq ch (get_char))))) 4155 (if (eq ch 21) 4156 (message "Cancelled." 1) 4157 (message "Unbound extended key sequence." 1)) 4158 4159 (clearline status_line 0) 4160 4161 (when (or (lastline) (allow_on_empty cmd)) 4162 (cmd local_count) 4163 (setq last_count local_count) 4164 (setq last_cmd cmd))))) 4165 4166 ; Clear the ASCII art from the screen 4167 4168 (when (fixnump (setq cmd (get_char))) 4169 (pushback cmd)) 4170 4171 (redisplay 1) 4172 4173 ; Toplevel Loop. 4174 4175 (loop 4176 (unless (setq local_count count) 4177 (setq local_count 1)) 4178 4179 (setq count 0) 4180 4181 (cond ((setq cmd (lookup commands (setq ch (get_char)))) 4182 (if (not winch) 4183 (clearline status_line 0) 4184 (message "Window resized." 1) 4185 (setq winch 0)) 4186 4187 (goto r c) 4188 4189 (if (eq cmd 1) 4190 (extended_cmd) 4191 4192 (when (or (lastline) (allow_on_empty cmd)) 4193 (cmd local_count) 4194 (setq last_count local_count) 4195 (setq last_cmd cmd)))) 4196 4197 ((eq 0 cmd) 4198 (if (not last_cmd) 4199 (message "No previous command to repeat." 1) 4200 (last_cmd last_count))) 4201 4202 (1 (if (or (and (fixnump ch) (> ch 31) (< ch 127)) (eq ch 9) (eq ch 10) (eq ch 13)) 4203 (while local_count 4204 (insert_char ch) 4205 (dec local_count)) 4206 4207 (if (stringp ch) 4208 (suspend_editor 0) 4209 (message "Unbound key code" 1))))))) 4210