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 cbabca895aef3bc52eb63762c5f6b6a9830bb037..e85581bc25d45b16122e5f140373f56008680ef8 100644 (file)
--- 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 0b6d69b441898f5e584be8d46518cc24cd1ddd0d..ce092cc26e2c00fe8cda31f77bcc49403607bd11 100644 (file)
--- 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 20e2e0f073eb4ad4e2b7acda8ead5e996aeda123..e648880f1f221ff2260b6db5ee78664882ef4d09 100644 (file)
--- 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 a061cdeb7664a46426c6f61929b6be92de3efab4..1b3db974a25d7971cfb073ee3df983366713c9cc 100644 (file)
--- 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)
 )
-