From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 30 Apr 2017 08:03:51 +0000 (-0700)
Subject: Ham-handed elimination of legacy strings from win32 package.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~101
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9682e313ff019682adf76d04dcf123328a21a656;p=mit-scheme.git

Ham-handed elimination of legacy strings from win32 package.

This package is probably broken now, but it's not obvious to me how to fix it in
a way consistent with our data types.
---

diff --git a/src/win32/clipbrd.scm b/src/win32/clipbrd.scm
index cbabca895..e85581bc2 100644
--- a/src/win32/clipbrd.scm
+++ b/src/win32/clipbrd.scm
@@ -47,15 +47,18 @@ USA.
   (let ((mem (get-clipboard-data CF_TEXT)))
     (and (not (= mem 0))
 	 (let* ((maxlen (global-size mem))
-		(s (make-legacy-string maxlen))
+		(bv (make-bytevector maxlen))
 		(ptr (global-lock mem)))
-	   (copy-memory s ptr maxlen)
+	   (copy-memory bv ptr maxlen)
 	   (global-unlock mem)
 	   (close-clipboard)
-	   (string-copy s
-			0
-			(or (string-find-first-index (char=-predicate #\null) s)
-			    maxlen))))))
+	   (iso8859-1->string bv
+			      0
+			      (let loop ((i 0))
+				(if (or (not (fix:< i maxlen))
+					(fix:= (bytevector-u8-ref bv i) 0))
+				    i
+				    (loop (fix:+ i 1)))))))))
 
 (define (win32-screen-width)
   (get-system-metrics SM_CXSCREEN))
diff --git a/src/win32/graphics.scm b/src/win32/graphics.scm
index 0b6d69b44..ce092cc26 100644
--- a/src/win32/graphics.scm
+++ b/src/win32/graphics.scm
@@ -261,14 +261,14 @@ USA.
       (default)))))
 
 (define (make-standard-palette)
-  (define pal (make-legacy-string (+ 4 (* 4 256))))
+  (define pal (make-bytevector (+ 4 (* 4 256))))
   (define i 0)
   (define (alloc r g b f)
     (let ((base (fix:+ 4 (fix:* i 4))))
-      (vector-8b-set! pal base       r)
-      (vector-8b-set! pal (+ base 1) g)
-      (vector-8b-set! pal (+ base 2) b)
-      (vector-8b-set! pal (+ base 3) f)
+      (bytevector-u8-set! pal base       r)
+      (bytevector-u8-set! pal (+ base 1) g)
+      (bytevector-u8-set! pal (+ base 2) b)
+      (bytevector-u8-set! pal (+ base 3) f)
       (set! i (1+ i))))
 
   ;; RGB intensities scaled to look good.  Notice that 128 is in the list
@@ -289,22 +289,22 @@ USA.
 	(if (not (= r g b))
 	    (alloc (vector-ref cv r) (vector-ref cv g) (vector-ref cv b)
 		   PC_NOCOLLAPSE)))))
-  (vector-8b-set! pal 0 #x00)
-  (vector-8b-set! pal 1 #x03)
-  (vector-8b-set! pal 2 (fix:and i 255))
-  (vector-8b-set! pal 3 (fix:lsh i -8))
+  (bytevector-u8-set! pal 0 #x00)
+  (bytevector-u8-set! pal 1 #x03)
+  (bytevector-u8-set! pal 2 (fix:and i 255))
+  (bytevector-u8-set! pal 3 (fix:lsh i -8))
   (create-palette pal)
 )
 
 (define (make-grayscale-palette)
-  (define pal (make-legacy-string (+ 4 (* 4 256))))
+  (define pal (make-bytevector (+ 4 (* 4 256))))
   (define i 0)
   (define (alloc r g b f)
     (let ((base (fix:+ 4 (fix:* i 4))))
-      (vector-8b-set! pal base           r)
-      (vector-8b-set! pal (fix:+ base 1) g)
-      (vector-8b-set! pal (fix:+ base 2) b)
-      (vector-8b-set! pal (fix:+ base 3) f)
+      (bytevector-u8-set! pal base           r)
+      (bytevector-u8-set! pal (fix:+ base 1) g)
+      (bytevector-u8-set! pal (fix:+ base 2) b)
+      (bytevector-u8-set! pal (fix:+ base 3) f)
       (set! i (1+ i))))
 
   (alloc 0 0 0 0)		; Black is matched
@@ -315,22 +315,22 @@ USA.
       ((> grey 254))
     (alloc grey grey grey PC_NOCOLLAPSE))
   (alloc 255 255 255 0)		; White is matched
-  (vector-8b-set! pal 0 #x00)
-  (vector-8b-set! pal 1 #x03)
-  (vector-8b-set! pal 2 (fix:and i 255))
-  (vector-8b-set! pal 3 (fix:lsh i -8))
+  (bytevector-u8-set! pal 0 #x00)
+  (bytevector-u8-set! pal 1 #x03)
+  (bytevector-u8-set! pal 2 (fix:and i 255))
+  (bytevector-u8-set! pal 3 (fix:lsh i -8))
   (create-palette pal)
 )
 
 (define (make-grayscale-128-palette)
-  (define pal (make-legacy-string (+ 4 (* 4 256))))
+  (define pal (make-bytevector (+ 4 (* 4 256))))
   (define i 0)
   (define (alloc r g b f)
     (let ((base (fix:+ 4 (fix:* i 4))))
-      (vector-8b-set! pal base           r)
-      (vector-8b-set! pal (fix:+ base 1) g)
-      (vector-8b-set! pal (fix:+ base 2) b)
-      (vector-8b-set! pal (fix:+ base 3) f)
+      (bytevector-u8-set! pal base           r)
+      (bytevector-u8-set! pal (fix:+ base 1) g)
+      (bytevector-u8-set! pal (fix:+ base 2) b)
+      (bytevector-u8-set! pal (fix:+ base 3) f)
       (set! i (1+ i))))
 
   (alloc 0 0 0 0)		; Black is matched
@@ -340,10 +340,10 @@ USA.
       ((> grey 254))
     (alloc grey grey grey PC_NOCOLLAPSE))
   (alloc 255 255 255 0)		; White is matched
-  (vector-8b-set! pal 0 #x00)
-  (vector-8b-set! pal 1 #x03)
-  (vector-8b-set! pal 2 (fix:and i 255))
-  (vector-8b-set! pal 3 (fix:lsh i -8))
+  (bytevector-u8-set! pal 0 #x00)
+  (bytevector-u8-set! pal 1 #x03)
+  (bytevector-u8-set! pal 2 (fix:and i 255))
+  (bytevector-u8-set! pal 3 (fix:lsh i -8))
   (create-palette pal)
 )
 
@@ -359,25 +359,25 @@ USA.
 			 (loop (+ i 1)))))))))
 
 (define (convert-palette external)
-  (let ((s (make-legacy-string (+ 4 (* 4 256))))
+  (let ((s (make-bytevector (+ 4 (* 4 256))))
 	(n-entries (vector-length external)))
-    (vector-8b-set! s 0 #x00)
-    (vector-8b-set! s 1 #x03)
-    (vector-8b-set! s 2 (fix:and #xFF n-entries))
-    (vector-8b-set! s 3 (fix:and #xFF (fix:lsh n-entries -8)))
+    (bytevector-u8-set! s 0 #x00)
+    (bytevector-u8-set! s 1 #x03)
+    (bytevector-u8-set! s 2 (fix:and #xFF n-entries))
+    (bytevector-u8-set! s 3 (fix:and #xFF (fix:lsh n-entries -8)))
     (do ((i 0 (fix:+ i 1))
 	 (j 4 (fix:+ j 4)))
 	((fix:= i n-entries))
       (let ((elt (vector-ref external i)))
 	(let ((rgb (remainder elt #x1000000))
 	      (bits (quotient elt #x1000000)))
-	  (vector-8b-set! s j (fix:and #xFF elt))
-	  (vector-8b-set! s (fix:+ j 1) (fix:and #xFF (fix:lsh elt -8)))
-	  (vector-8b-set! s (fix:+ j 2) (fix:and #xFF (fix:lsh elt -16)))
-	  (vector-8b-set! s (fix:+ j 3)
-			  (if (or (fix:= 0 rgb) (fix:= #xFFFFFF rgb))
-			      0
-			      bits)))))
+	  (bytevector-u8-set! s j (fix:and #xFF elt))
+	  (bytevector-u8-set! s (fix:+ j 1) (fix:and #xFF (fix:lsh elt -8)))
+	  (bytevector-u8-set! s (fix:+ j 2) (fix:and #xFF (fix:lsh elt -16)))
+	  (bytevector-u8-set! s (fix:+ j 3)
+			      (if (or (fix:= 0 rgb) (fix:= #xFFFFFF rgb))
+				  0
+				  bits)))))
     (create-palette s)))
 
 (define (client-width->window-width w)
@@ -620,7 +620,7 @@ USA.
 
 (define (make-C-point-vector window vec)
   (let* ((n  (vector-length vec))
-         (s  (make-legacy-string (* 4 n))))
+         (s  (make-bytevector (* 4 n))))
     (define (loop i)
       (if (fix:< i n)
 	(begin
@@ -764,8 +764,8 @@ USA.
 	 (rgb-hex spec 2))
 	((string? spec)
 	 (let  ((pair
-		 (list-search-positive color-table
-		   (lambda (pair) (string-ci=? (car pair) spec)))))
+		 (find (lambda (pair) (string-ci=? (car pair) spec))
+		       color-table)))
 	   (if pair
 	       (cdr pair)
 	       (graphics-error "Unknown color name:" spec))))
diff --git a/src/win32/win_ffi.scm b/src/win32/win_ffi.scm
index 20e2e0f07..e648880f1 100644
--- a/src/win32/win_ffi.scm
+++ b/src/win32/win_ffi.scm
@@ -209,7 +209,7 @@ USA.
          (C-proc    (get-window-long hwnd GWL_WNDPROC))
          (scheme?   (= C-proc scheme-wndproc))
 	 (old-proc  (if scheme?
-	                (or (hash-table/get wndproc-registry hwnd #f)
+			(or (hash-table/get wndproc-registry hwnd #f)
 			    default-scheme-wndproc)
 			(lambda (hw m w l)
 			  (%call-foreign-function c-proc hw m w l)))))
@@ -234,12 +234,12 @@ USA.
 
 
 (define (make-message-polling-loop)
-  (define msg (make-legacy-string 40))
+  (define msg (make-bytevector 40))
   (define (message-polling-loop)
     (if (peek-message msg 0 0 0 1 #|PM_REMOVE|#)
         (begin
 	  (translate-message msg)
-	  (without-interrupts (lambda()(dispatch-message msg)))
+	  (without-interrupts (lambda() (dispatch-message msg)))
 	  (message-polling-loop))))
   message-polling-loop)
 
diff --git a/src/win32/wt_user.scm b/src/win32/wt_user.scm
index a061cdeb7..1b3db974a 100644
--- a/src/win32/wt_user.scm
+++ b/src/win32/wt_user.scm
@@ -32,17 +32,17 @@ USA.
 (declare (usual-integrations))
 
 
-(define-integrable int32-offset-ref   
+(define-integrable int32-offset-ref
           (ucode-primitive int32-offset-ref 2))
-(define-integrable int32-offset-set!  
+(define-integrable int32-offset-set!
           (ucode-primitive int32-offset-set! 3))
-(define-integrable uint32-offset-ref  
+(define-integrable uint32-offset-ref
           (ucode-primitive uint32-offset-ref 2))
-(define-integrable uint32-offset-set! 
+(define-integrable uint32-offset-set!
           (ucode-primitive uint32-offset-set! 3))
 
-(define-integrable byte-offset-ref  vector-8b-ref)	    
-(define-integrable byte-offset-set! vector-8b-set!)	    
+(define-integrable byte-offset-ref  bytevector-u8-ref)
+(define-integrable byte-offset-set! bytevector-u8-set!)
 
 (define-integrable (loword dword)  (modulo dword 65536))
 (define-integrable (hiword dword)  (integer-floor dword 65536))
@@ -72,7 +72,7 @@ USA.
 (define-integrable (set-rect/bottom! r v) (int32-offset-set! (rect/mem r) 12 v))
 
 (define (make-rect left top right bottom)
-  (define r (%make-rect (make-legacy-string 16)))
+  (define r (%make-rect (make-bytevector 16)))
   (set-rect/left!   r left)
   (set-rect/top!    r top)
   (set-rect/right!  r right)
@@ -134,7 +134,7 @@ USA.
   (byte-offset-set! (paintstruct/mem r) 28 (bool->int v)))
 
 (define (make-paintstruct)
-  (define r (%make-paintstruct (make-legacy-string 64)))
+  (define r (%make-paintstruct (make-bytevector 64)))
   r)
 
 (define-windows-type paintstruct
@@ -161,4 +161,3 @@ USA.
   (pp-field 'f-restore paintstruct/f-restore)
   (pp-field 'f-inc-update paintstruct/f-inc-update)
 )
-