home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / KILL.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  3.5 KB  |  93 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;;; Kill Commands
  43.  
  44. (define append-next-kill-tag "Append Next Kill")
  45.  
  46. (define (delete-region mark)
  47.   (if (not mark) (editor-error "Delete exceeds buffer bounds"))
  48.   (region-delete! (make-region (current-point) mark)))
  49.  
  50. (define (kill-region mark)
  51.   (if (not mark) (editor-error "Kill exceeds buffer bounds"))
  52.   (let* ((point (current-point))
  53.          (forward? (mark<= point mark)))
  54.     (%kill-region (region-extract! (make-region point mark)) forward?)))
  55.  
  56. (define (%kill-region region forward?)
  57.   (let ((ring (current-kill-ring)))
  58.     (command-message-receive append-next-kill-tag
  59.       (lambda ()
  60.     (if (ring-empty? ring) (editor-error "No previous kill"))
  61.     (region-insert! ((if forward? region-end region-start)
  62.              (ring-ref ring 0))
  63.             region))
  64.       (lambda ()
  65.     (ring-push! ring region))))
  66.   (set-command-message! append-next-kill-tag))
  67.  
  68. (define (un-kill-region region)
  69.   (set-current-region! (region-insert (current-point) region)))
  70.  
  71. (define (copy-region mark)
  72.   (if (not mark) (editor-error "Copy exceeds buffer bounds"))
  73.   (let ((point (current-point)))
  74.     (%kill-region (region-copy (make-region point mark))
  75.           (mark<= point mark))))
  76.  
  77. (define (un-kill-region-reversed region)
  78.   (set-current-region-reversed! (region-insert (current-point) region)))
  79.  
  80. (define (%edwin-un-kill-pop argument)
  81.   (command-message-receive un-kill-tag
  82.     (lambda ()
  83.       (region-delete! (make-region (current-point) (pop-current-mark!)))
  84.       (let ((ring (current-kill-ring)))
  85.     ;; **** Missing test for equality here.
  86.     (if (not (zero? argument))
  87.         (begin (ring-pop! ring)
  88.            (un-kill-region-reversed (ring-ref ring 0))))))
  89.     (lambda ()
  90.       (editor-error "No previous un-kill to replace")))
  91.   (set-command-message! un-kill-tag))
  92.  
  93.