From: Chris Hanson Date: Tue, 2 May 1995 21:19:22 +0000 (+0000) Subject: Integrate support for OS-dependent cut&paste buffer into the kill and X-Git-Tag: 20090517-FFI~6356 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e2235d52efedcf274f35e3deda9133af3feccc4c;p=mit-scheme.git Integrate support for OS-dependent cut&paste buffer into the kill and yank commands, as is done in Emacs 19. This support is available in the OS/2 implementation. --- diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm index 4c885d343..e9b1219e7 100644 --- a/v7/src/edwin/dos.scm +++ b/v7/src/edwin/dos.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dos.scm,v 1.23 1995/04/09 23:27:54 cph Exp $ +;;; $Id: dos.scm,v 1.24 1995/05/02 21:19:13 cph Exp $ ;;; ;;; Copyright (c) 1992-95 Massachusetts Institute of Technology ;;; @@ -469,4 +469,11 @@ Includes the new backup. Must be > 0." "sendmail.exe") (define (os/rmail-pop-procedure) + #f) + +(define (os/interprogram-cut string) + string push? + unspecific) + +(define (os/interprogram-paste) #f) \ No newline at end of file diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index aaa15e996..fe7050a71 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.170 1995/04/30 06:52:22 cph Exp $ +$Id: edwin.pkg,v 1.171 1995/05/02 21:18:47 cph Exp $ Copyright (c) 1989-95 Massachusetts Institute of Technology @@ -1154,7 +1154,10 @@ MIT in each case. |# ((os/2) (extend-package (edwin) - (files "os2")) + (files "os2") + (import (runtime os2-window-primitives) + os2-clipboard-read-text + os2-clipboard-write-text)) (extend-package (edwin dired) (files "diros2") diff --git a/v7/src/edwin/kilcom.scm b/v7/src/edwin/kilcom.scm index 7a82b355d..82a724ab9 100644 --- a/v7/src/edwin/kilcom.scm +++ b/v7/src/edwin/kilcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: kilcom.scm,v 1.64 1993/01/10 10:47:06 cph Exp $ +;;; $Id: kilcom.scm,v 1.65 1995/05/02 21:18:58 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-95 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -217,25 +217,30 @@ The command \\[yank] can retrieve it from there. (lambda () (if (null? strings) (editor-error "No previous kill")) - (set-car! strings - (if forward? - (string-append (car strings) string) - (string-append string (car strings)))) - (set-variable! kill-ring-yank-pointer strings)) + (let ((string + (if forward? + (string-append (car strings) string) + (string-append string (car strings))))) + (set-car! strings string) + (set-variable! kill-ring-yank-pointer strings) + (os/interprogram-cut string))) (lambda () - (let ((strings - (let ((kill-ring-max (ref-variable kill-ring-max))) - (if (zero? kill-ring-max) - '() - (let ((strings (cons string strings))) - (if (> (length strings) kill-ring-max) - (set-cdr! (list-tail strings (- kill-ring-max 1)) - '())) - strings))))) - (set-variable! kill-ring strings) - (set-variable! kill-ring-yank-pointer strings))))) + (kill-ring-save-1 string) + (os/interprogram-cut string)))) (set-command-message! append-next-kill-tag)) +(define (kill-ring-save-1 string) + (let ((strings + (let ((kill-ring-max (ref-variable kill-ring-max))) + (if (zero? kill-ring-max) + '() + (let ((strings (cons string strings))) + (if (> (length strings) kill-ring-max) + (set-cdr! (list-tail strings (- kill-ring-max 1)) '())) + strings))))) + (set-variable! kill-ring strings) + (set-variable! kill-ring-yank-pointer strings))) + (define append-next-kill-tag "Append Next Kill") @@ -287,7 +292,18 @@ comes the newest one." ((ref-command rotate-yank-pointer) offset) (let* ((start (mark-right-inserting-copy (current-point))) (end (mark-left-inserting-copy start))) - (insert-string (car (ref-variable kill-ring-yank-pointer)) start) + (insert-string (let ((string (car (ref-variable kill-ring-yank-pointer))) + (string* + (and (= offset 0) + (os/interprogram-paste)))) + (if (and string* + (not (string-null? string*)) + (not (string=? string* string))) + (begin + (kill-ring-save-1 string*) + string*) + string)) + start) (mark-temporary! end) (mark-temporary! start) (if before? diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm index bab706605..5b72368f6 100644 --- a/v7/src/edwin/os2.scm +++ b/v7/src/edwin/os2.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: os2.scm,v 1.13 1995/05/02 00:29:23 cph Exp $ +;;; $Id: os2.scm,v 1.14 1995/05/02 21:18:40 cph Exp $ ;;; ;;; Copyright (c) 1994-95 Massachusetts Institute of Technology ;;; @@ -357,6 +357,15 @@ Includes the new backup. Must be > 0." (define (os/set-file-modes-writable! pathname) (set-file-modes! pathname (fix:andc (file-modes pathname) #x0001))) + +(define (os/interprogram-cut string push?) + push? + (os2-clipboard-write-text + ;; Some programs can't handle strings over 64k. + (if (fix:< (string-length string) #x10000) string ""))) + +(define os/interprogram-paste + os2-clipboard-read-text) ;;;; Dired customization diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index fb720c0c2..b2a52c605 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: unix.scm,v 1.48 1995/04/15 06:14:01 cph Exp $ +;;; $Id: unix.scm,v 1.49 1995/05/02 21:19:22 cph Exp $ ;;; ;;; Copyright (c) 1989-95 Massachusetts Institute of Technology ;;; @@ -704,4 +704,11 @@ Value is a list of strings." (ns (decoded-time/minute dt) 2 #\0)) (string-append " " (number->string - (decoded-time/year dt))))))) \ No newline at end of file + (decoded-time/year dt))))))) + +(define (os/interprogram-cut string push?) + string push? + unspecific) + +(define (os/interprogram-paste) + #f) \ No newline at end of file