From a85f85340674acc4fb78e9f1f5cffabe7376e852 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 9 Jul 1998 04:29:29 +0000
Subject: [PATCH] Fix bug in clipboard implementation.

---
 v7/src/win32/clipbrd.scm | 62 ++++++++++++++++++++--------------------
 v7/src/win32/make.scm    |  4 +--
 2 files changed, 33 insertions(+), 33 deletions(-)

diff --git a/v7/src/win32/clipbrd.scm b/v7/src/win32/clipbrd.scm
index 381353a66..ef16a6d95 100644
--- a/v7/src/win32/clipbrd.scm
+++ b/v7/src/win32/clipbrd.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: clipbrd.scm,v 1.2 1996/10/07 18:17:17 cph Exp $
+;;;	$Id: clipbrd.scm,v 1.3 1998/07/09 04:29:29 cph Exp $
 ;;;
-;;;	Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;	Copyright (c) 1995-98 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -42,39 +42,39 @@
 ;;; of that license should have been included along with this file.
 
 ;;;; Miscellaneous Win32 Facilities
+
+(declare (usual-integrations))
 
 (define (win32-clipboard-write-text s)
-  (let ((clip? (open-clipboard 0)))
-    (and clip?
-	 (let* ((len  (+ (string-length s) 1))
-		(mem  (global-alloc #x2002 #|= GMEM_MOVEABLE + GMEM_DDESHARE|#
-				    len)))
-	   (if (= mem 0)
-	       #F
-	       (let ((ptr  (global-lock mem)))
-		 (if (= ptr 0)
-		     #F
-		     (begin
-		       (copy-memory ptr s len)
-		       (global-unlock mem)
-		       (set-clipboard-data CF_TEXT mem)
-		       (close-clipboard)))))))))
+  (let* ((len (+ (string-length s) 1))
+	 (mem
+	  (global-alloc #x2002		;(GMEM_MOVEABLE | GMEM_DDESHARE)
+			len)))
+    (if (= mem 0)
+	(error "Unable to allocate global memory of length" len))
+    (copy-memory (global-lock mem) s len)
+    (global-unlock mem)
+    (if (not (open-clipboard 0))
+	(error "Error opening clipboard."))
+    (if (not (empty-clipboard))
+	(error "Error emptying clipboard."))
+    (if (not (set-clipboard-data CF_TEXT mem))
+	(error "Error setting clipboard data."))
+    (if (not (close-clipboard))
+	(error "Error closing clipboard."))))
 
 (define (win32-clipboard-read-text)
-  (let ((clip? (open-clipboard 0)))
-    (and clip?
-	 (let* ((mem  (get-clipboard-data CF_TEXT)))
-	   (if (= mem 0)
-	       #F
-	       (let* ((maxlen (global-size mem))
-		      (s      (string-allocate maxlen))
-		      (ptr    (global-lock mem)))
-		 (copy-memory s ptr maxlen)
-		 (global-unlock mem)
-		 (close-clipboard)
-		 (let ((end (vector-8b-find-next-char s 0 maxlen 0)))
-		   (set-string-length! s end))
-		 s))))))
+  (open-clipboard 0)
+  (let ((mem (get-clipboard-data CF_TEXT)))
+    (and (not (= mem 0))
+	 (let* ((maxlen (global-size mem))
+		(s (string-allocate maxlen))
+		(ptr (global-lock mem)))
+	   (copy-memory s ptr maxlen)
+	   (global-unlock mem)
+	   (close-clipboard)
+	   (set-string-length! s (vector-8b-find-next-char s 0 maxlen 0))
+	   s))))
 
 (define (win32-screen-width)
   (get-system-metrics SM_CXSCREEN))
diff --git a/v7/src/win32/make.scm b/v7/src/win32/make.scm
index 7db67da38..d23f5cb59 100644
--- a/v7/src/win32/make.scm
+++ b/v7/src/win32/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 1.4 1998/02/12 04:35:20 cph Exp $
+$Id: make.scm,v 1.5 1998/07/09 04:29:16 cph Exp $
 
 Copyright (c) 1993-98 Massachusetts Institute of Technology
 
@@ -48,7 +48,7 @@ MIT in each case. |#
 
 ;((package/reference (find-package '(WIN32))
 ;		    'INITIALIZE-PACKAGE!))
-(add-identification! "Win32" 1 4)
+(add-identification! "Win32" 1 5)
 
 
 (define (package-initialize package-name procedure-name mandatory?)
-- 
2.25.1