From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 28 Dec 2022 05:47:36 +0000 (-0800)
Subject: Fix graphics bug reported by GJS.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b873d78f125aeb65a253b244457b9ce64d8af659;p=mit-scheme.git

Fix graphics bug reported by GJS.
---

diff --git a/src/x11/x11-device.scm b/src/x11/x11-device.scm
index d9a73532f..0feacb35b 100644
--- a/src/x11/x11-device.scm
+++ b/src/x11/x11-device.scm
@@ -44,6 +44,31 @@ USA.
   (+ event-mask:normal (shift-left 1 event-type:take-focus)))
 
 (define user-event-mask:default (shift-left 1 event-type:button-down))
+
+(define (->flovec object)
+  (cond ((flo:flonum? object)
+	 object)
+	((vector-of-type? object number?)
+	 (let* ((n (vector-length object))
+		(v (flo:vector-cons n)))
+	   (let loop ((i 0))
+	     (if (fix:< i n)
+		 (begin
+		   (flo:vector-set! v i (->flonum (vector-ref object i)))
+		   (loop (fix:+ i 1)))))
+	   v))
+	((list-of-type?->length object number?)
+	 => (lambda (n)
+	      (let ((v (flo:vector-cons n)))
+		(let loop ((i 0) (items object))
+		  (if (pair? items)
+		      (begin
+			(flo:vector-set! v i (->flonum (car items)))
+			(loop (fix:+ i 1) (cdr items)))))
+		v)))
+	(else
+	 (error:wrong-type-argument object "list/vector of numbers"
+				    '->flovec))))
 
 ;;;; X11 graphics device
 
@@ -477,7 +502,9 @@ USA.
 			(->flonum y-end)))
 
 (define (x-graphics/draw-lines device xv yv)
-  (x-graphics-draw-lines (x-graphics-device/xw device) xv yv))
+  (x-graphics-draw-lines (x-graphics-device/xw device)
+			 (->flovec xv)
+			 (->flovec yv)))
 
 (define (x-graphics/draw-point device x y)
   (x-graphics-draw-point (x-graphics-device/xw device)
@@ -485,7 +512,9 @@ USA.
 			 (->flonum y)))
 
 (define (x-graphics/draw-points device xv yv)
-  (x-graphics-draw-points (x-graphics-device/xw device) xv yv))
+  (x-graphics-draw-points (x-graphics-device/xw device)
+			  (->flovec xv)
+			  (->flovec yv)))
 
 (define (x-graphics/draw-text device x y string)
   (x-graphics-draw-string (x-graphics-device/xw device)
@@ -610,9 +639,9 @@ USA.
 		       360.
 		       #t))
 
-(define (x-graphics/fill-polygon device point-vector)
+(define (x-graphics/fill-polygon device points)
   (x-graphics-fill-polygon (x-graphics-device/xw device)
-			   (vector-map ->flonum point-vector)))
+			   (->flovec points)))
 
 (define (x-graphics/copy-area device source-x-left source-y-top width height
 			      destination-x-left destination-y-top)
diff --git a/src/x11/x11-graphics.scm b/src/x11/x11-graphics.scm
index 3d0b36234..230615fc6 100644
--- a/src/x11/x11-graphics.scm
+++ b/src/x11/x11-graphics.scm
@@ -139,7 +139,7 @@ USA.
 
 (define (x-graphics-draw-points window x-vector y-vector)
   (let* ((n-points (flo:vector-length x-vector))
-	 (points (malloc (* n-points (C-sizeof "XPoint")))))
+	 (points (malloc (* n-points (C-sizeof "XPoint")) '|XPoint|)))
     (if (not (= n-points (flo:vector-length y-vector)))
 	(error:bad-range-argument y-vector 'x-graphics-draw-points))
     (C-call "x_graphics_draw_points" window x-vector y-vector n-points points)
@@ -147,7 +147,7 @@ USA.
 
 (define (x-graphics-draw-lines window x-vector y-vector)
   (let* ((n-points (flo:vector-length x-vector))
-	 (points (malloc (* n-points (C-sizeof "XPoint")))))
+	 (points (malloc (* n-points (C-sizeof "XPoint")) '|XPoint|)))
     (if (not (= n-points (flo:vector-length y-vector)))
 	(error:bad-range-argument y-vector 'x-graphics-draw-lines))
     (C-call "x_graphics_draw_lines" window x-vector y-vector n-points points)
@@ -179,7 +179,7 @@ USA.
   (let ((length (flo:vector-length vector)))
     (if (not (even? length))
 	(error:bad-range-argument vector 'x-graphics-fill-polygon))
-    (let ((points (malloc (* (/ length 2) (C-sizeof "XPoint")))))
+    (let ((points (malloc (* (/ length 2) (C-sizeof "XPoint")) '|XPoint|)))
       (C-call "x_graphics_fill_polygon" window vector length points)
       (free points))))