From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 7 Oct 1996 18:20:31 +0000 (+0000)
Subject: Implement M-x set-frame-size.  Fix bug in M-x show-frame-size.
X-Git-Tag: 20090517-FFI~5362
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0d9a721a1d4a889bb1d79c590d7a6a7c6082153e;p=mit-scheme.git

Implement M-x set-frame-size.  Fix bug in M-x show-frame-size.
---

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 0e0bef9e8..5255b524f 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.197 1996/05/14 01:50:03 cph Exp $
+$Id: edwin.pkg,v 1.198 1996/10/07 18:20:31 cph Exp $
 
 Copyright (c) 1989-96 Massachusetts Institute of Technology
 
@@ -1157,8 +1157,12 @@ MIT in each case. |#
     (files "win32")
     (parent (edwin screen))
     (import (win32)
+	    adjust-window-rect
 	    destroy-window
+	    get-client-rect
 	    get-handle
+	    get-menu
+	    get-system-metrics
 	    get-window-rect
 	    load-icon
 	    make-rect
@@ -1174,11 +1178,18 @@ MIT in each case. |#
 	    set-window-text
 	    show-window
 	    sleep
+	    sm_cxframe
+	    sm_cycaption
+	    sm_cyframe
+	    sm_cymenu
 	    sw_showminnoactive
+	    swp_nomove
 	    swp_nosize
 	    swp_nozorder
-	    update-window)
+	    update-window
+	    ws_overlappedwindow)
     (export (edwin win-commands)
+	    win32-screen/get-client-size
 	    win32-screen/get-position
 	    win32-screen/set-background-color!
 	    win32-screen/set-font!
@@ -1211,6 +1222,7 @@ MIT in each case. |#
 	    edwin-command$set-font
 	    edwin-command$set-foreground-color
 	    edwin-command$set-frame-position
+	    edwin-command$set-frame-size
 	    edwin-command$set-icon
 	    edwin-command$show-frame-position
 	    edwin-command$show-frame-size)
diff --git a/v7/src/edwin/win32.scm b/v7/src/edwin/win32.scm
index 76b8f8b3e..8fd7518ab 100644
--- a/v7/src/edwin/win32.scm
+++ b/v7/src/edwin/win32.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: win32.scm,v 1.5 1996/03/21 16:52:57 adams Exp $
+;;;	$Id: win32.scm,v 1.6 1996/10/07 18:20:09 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994-96 Massachusetts Institute of Technology
 ;;;
@@ -48,22 +48,23 @@
 (declare (usual-integrations))
 
 (define-primitives
-  (win32-screen-get-event 1)
+  (win32-screen-char-dimensions 1)
   (win32-screen-clear-rectangle! 6)
-  (win32-screen-invalidate-rect! 5)
-  (win32-screen-vertical-scroll! 6)
-  (win32-screen-write-char! 5)
-  (win32-screen-move-cursor! 3)
-  (win32-screen-size 1)
   (win32-screen-create! 2)
-  (win32-screen-write-substring! 7)
-  (win32-screen-show-cursor! 2)
   (win32-screen-current-focus 0)
-  (win32-screen-set-icon! 2)
+  (win32-screen-get-event 1)
+  (win32-screen-invalidate-rect! 5)
+  (win32-screen-move-cursor! 3)
+  (win32-screen-set-background-color! 2)
   (win32-screen-set-default-font! 1)
   (win32-screen-set-font! 2)
   (win32-screen-set-foreground-color! 2)
-  (win32-screen-set-background-color! 2))
+  (win32-screen-set-icon! 2)
+  (win32-screen-show-cursor! 2)
+  (win32-screen-size 1)
+  (win32-screen-vertical-scroll! 6)
+  (win32-screen-write-char! 5)
+  (win32-screen-write-substring! 7))
 
 (define-integrable event:process-output 16)
 (define-integrable event:process-status 32)
@@ -71,7 +72,6 @@
 
 (define win32-screens '())
 
-
 ;;(define (debug . details)
 ;;  (pp details console-output-port))
 
@@ -90,15 +90,13 @@
   (rect-left 0)
   (redisplay-title? #F)
   (name #F))
-  
 
 (define-integrable (screen-redisplay-title? screen)
   (state/redisplay-title? (screen-state screen)))
 
 (define-integrable (set-screen-redisplay-title?! screen flag)
   (set-state/redisplay-title?! (screen-state screen) flag))
-
-
+
 (define (make-win32-screen)
   (let* ((window (win32-screen-create! 0 win32-screen-features-mask))
 	 (icon   (load-icon (get-handle 0) "EDWIN_ICON"))
@@ -134,7 +132,6 @@
       ;;(debug 'CREATE screen)
       screen)))
 
-
 (define (win32-screen/beep screen)
   screen
   (message-beep -1))
@@ -157,7 +154,6 @@
 		   (max right  (state/rect-right state)))
 	(set-rect! state top bottom left right))))
 
-
 (define (invalidate-invalid-region! screen)
   (let ((state  (screen-state screen)))
     (if (state/rect-top state)
@@ -169,12 +165,10 @@
 	   (state/rect-left state)
 	   (fix:+ (state/rect-right state) 1))))))
 
-
 (define-integrable (set-screen-cursor-position! screen x y)
   (set-state/cursor-x! (screen-state screen) x)
   (set-state/cursor-y! (screen-state screen) y))
-
-
+
 (define (win32-screen/clear-line! screen x y first-unused-x)
   (win32-screen-clear-rectangle! (screen->handle screen)
 				 x first-unused-x y (fix:1+ y)
@@ -209,7 +203,6 @@
   window type				; ignored
   (set-screen-redisplay-title?! screen true))
 
-
 (define (win32-screen/scroll-lines-down! screen xl xu yl yu amount)
   (and #F
        (win32-screen-vertical-scroll! (screen->handle screen)
@@ -222,7 +215,6 @@
        (win32-screen-vertical-scroll! (screen->handle screen)
 				      xl xu yl yu (fix:- yl amount))))
 
-
 (define (win32-screen/flush! screen)
   ;; Win32 API call causes any pending painting to be done
   (update-window (screen->handle screen))
@@ -245,9 +237,9 @@
 	     (update-win32-screen-name! screen)
 	     (set-screen-redisplay-title?! screen false)))
        (win32-screen/flush! screen)))))
-
+
 (define (win32-screen/write-char! screen x y char highlight)
-  (win32-screen-write-char! (screen->handle screen) x y 
+  (win32-screen-write-char! (screen->handle screen) x y
 			    (char->integer char)
 			    (if highlight 1 0))
   (if (char-graphic? char)
@@ -261,7 +253,6 @@
    (if highlight 1 0))
   (expand-rect screen x (fix:+ x (fix:- end start)) y y))
 
-
 (define (win32-screen/write-cursor! screen x y)
   (let ((state  (screen-state screen)))
     (if (or (not (fix:= (state/cursor-x state) x))
@@ -282,15 +273,14 @@
 (define (handle->win32-screen handle)
   (list-search-positive win32-screens
     (lambda (screen) (eqv? handle (state/handle (screen-state screen))))))
-
-
+
 (define win32-display-type)
 
 (define (win32-screen-available?)
   (implemented-primitive-procedure? win32-screen-create!))
 
 (define (initialize-package!)
-  (set! win32-display-type 
+  (set! win32-display-type
 	(make-display-type 'win32
 			   true        ; multiple screens?
 			   win32-screen-available?
@@ -318,7 +308,7 @@
 
 (define (with-win32-interrupts-disabled thunk)
   (with-signal-interrupts false thunk))
-  
+
 (define (with-signal-interrupts enabled? thunk)
   (let ((old))
     (dynamic-wind (lambda ()
@@ -337,7 +327,7 @@
   (^G-signal))
 
 (define signal-interrupts? #f)
-
+
 (define-integrable (some-bits? mask item)
   (not (fix:= 0 (fix:and mask item))))
 
@@ -360,8 +350,7 @@
   event
   (make-input-event 'SET-SCREEN-SIZE
 		    (lambda (screen)
-		      (let ((w.h (win32-screen-size
-				  (screen->handle screen))))
+		      (let ((w.h (win32-screen-size (screen->handle screen))))
 			(if (not (and (= (car w.h) (screen-x-size screen))
 				      (= (cdr w.h) (screen-y-size screen))))
 			    (begin
@@ -373,11 +362,11 @@
   event
   (cond ((screen-deleted? screen)  #F)
 	((= (length win32-screens) 1)
-	 (make-input-event 'EXIT save-buffers-and-exit #F "Scheme" exit-scheme))
+	 (make-input-event 'EXIT save-buffers-and-exit #F "Scheme"
+			   exit-scheme))
 	(else
 	 (make-input-event 'DELETE-SCREEN delete-screen! screen))))
 
-
 (define (process-key-event event)
   (let* ((key        (vector-ref event 5))
 	 (cont-state (vector-ref event 4))
@@ -404,8 +393,7 @@
 		 (else
 		  (integer->char key)))))
       result)))
-
-	
+
 (define (get-win32-input-operations screen)
 
   screen ; ignored
@@ -503,21 +491,21 @@
 		  (else
 		   (guarantee-result))))))
 
-    (values halt-update?	         
+    (values halt-update?
 	    peek-no-hang
 	    peek
 	    read)))
-
-
-;; The INPUT-SCREEN is the current screen from which we are processing input
-;; events.  When a different screen (or some window from sone other application)
-;; may have been selected, INPUT-SCREEN is set to #F.  This causes READ-EVENT-1
-;; to hunt for a screen from which it can take input events.
-;; This is a crock.  An improvement would be to put the input events for
-;; Edwin screens into a common queue, and invent an new `select-screen' event
-;; That in turn would require implementing the queues separately from the window
-;; but it would move the place at which the process should be suspended to
-;; a single place (WIN32-SCREEN-GET-EVENT), allowing a WIN32(C?) event and
+
+;; The INPUT-SCREEN is the current screen from which we are processing
+;; input events.  When a different screen (or some window from sone
+;; other application) may have been selected, INPUT-SCREEN is set to
+;; #F.  This causes READ-EVENT-1 to hunt for a screen from which it
+;; can take input events.  This is a crock.  An improvement would be
+;; to put the input events for Edwin screens into a common queue, and
+;; invent an new `select-screen' event That in turn would require
+;; implementing the queues separately from the window but it would
+;; move the place at which the process should be suspended to a single
+;; place (WIN32-SCREEN-GET-EVENT), allowing a WIN32(C?) event and
 
 (define input-screen)
 
@@ -565,23 +553,22 @@
 		     (if screen*
 			 (begin
 			   (set! input-screen screen*)
-			   (make-input-event 'SELECT-SCREEN select-screen screen*))
+			   (make-input-event 'SELECT-SCREEN
+					     select-screen
+					     screen*))
 			 (return-or-block #F))))
 		  (else
 		   (let ((result (win32-screen-get-event screen-handle)))
 		     (set-interrupt-enables! interrupt-mask)
 		     ;; in lieu of blocking we give up our timeslice.
 		     (return-or-block result)))))))))
-
-
+
 (define (process-change-event event)
   (cond ((fix:= event event:process-output) (accept-process-output))
 	((fix:= event event:process-status) (handle-process-status-changes))
 	((fix:= event event:inferior-thread-output) (accept-thread-output))
 	(else (error "Illegal change event:" event))))
 
-
-
 (define-integrable (screen-name screen)
   (state/name (screen-state screen)))
 
@@ -596,7 +583,15 @@
 	  (set-window-text (screen->handle screen) name)))))
 
 (define (win32-screen/set-font! screen font)
-  (win32-screen-set-font! (screen->handle screen) font))
+  (let ((x-size (screen-x-size screen))
+	(y-size (screen-y-size screen)))
+    (win32-screen-set-font! (screen->handle screen) font)
+    ;; This doesn't work, for no obvious reason.  The screen ends up
+    ;; being either too large or too small.  I guess there is some
+    ;; kind of timing error that causes the new size of the screen to
+    ;; be mis-computed by use of old information.
+    ;;(win32-screen/set-size! screen x-size y-size)
+    ))
 
 (define (win32-screen/set-icon! screen icon)
   (win32-screen-set-icon! (screen->handle screen) icon))
@@ -607,19 +602,30 @@
 (define (win32-screen/set-background-color! screen color)
   (win32-screen-set-background-color! (screen->handle screen) color))
 
-;; Missing functionality: to specify the screen's size in characters
-;;
-;;(define (win32-screen/set-size! screen width height)
-;;  (?? (screen->handle screen) width height)
-;;  (update-screen! screen #T))
+(define (win32-screen/set-size! screen width height)
+  (let ((handle (screen->handle screen)))
+    (let ((rect
+	   (let ((x.y (win32-screen-char-dimensions handle)))
+	     (make-rect 0 0 (* width (car x.y)) (* height (cdr x.y))))))
+      (adjust-window-rect rect
+			  WS_OVERLAPPEDWINDOW
+			  (not (= 0 (get-menu handle))))
+      (set-window-pos handle 0 0 0
+		      (- (rect/right rect) (rect/left rect))
+		      (- (rect/bottom rect) (rect/top rect))
+		      (+ SWP_NOMOVE SWP_NOZORDER)))))
 
 (define (win32-screen/set-position! screen x y)
-  (set-window-pos (screen->handle screen) 0 0 0
-		  x y
+  (set-window-pos (screen->handle screen) 0 x y 0 0
 		  (+ SWP_NOSIZE SWP_NOZORDER)))
 
 (define (win32-screen/get-position screen)
-  (let  ((rect (make-rect 0 0 0 0)))
+  (let ((rect (make-rect 0 0 0 0)))
     (get-window-rect (screen->handle screen) rect)
     (values (rect/left rect) (rect/top rect)
-	    (rect/right rect) (rect/bottom rect))))
\ No newline at end of file
+	    (rect/right rect) (rect/bottom rect))))
+
+(define (win32-screen/get-client-size screen)
+  (let ((rect (make-rect 0 0 0 0)))
+    (get-client-rect (screen->handle screen) rect)
+    (values (rect/right rect) (rect/bottom rect))))
\ No newline at end of file
diff --git a/v7/src/edwin/win32com.scm b/v7/src/edwin/win32com.scm
index 4d65da824..6e723bd66 100644
--- a/v7/src/edwin/win32com.scm
+++ b/v7/src/edwin/win32com.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: win32com.scm,v 1.6 1996/05/03 06:58:59 cph Exp $
+;;;	$Id: win32com.scm,v 1.7 1996/10/07 18:19:13 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994-96 Massachusetts Institute of Technology
 ;;;
@@ -104,15 +104,14 @@ When called interactively, completion is available on the input."
   (lambda (font)
     ((ucode-primitive win32-screen-set-default-font! 1) font)))
 
-;; Missing functionality in win32-screen.
-;;(define-command set-frame-size
-;;  "Set size of current frame to WIDTH x HEIGHT."
-;;  "nFrame width (chars)\nnFrame height (chars)"
-;;  (lambda (width height)
-;;    (win32-screen/set-size! (selected-screen) (max 2 width) (max 2 height))))
+(define-command set-frame-size
+  "Set size of editor frame to WIDTH x HEIGHT."
+  "nFrame width (chars)\nnFrame height (chars)"
+  (lambda (width height)
+    (win32-screen/set-size! (selected-screen) (max 2 width) (max 2 height))))
 
 (define-command set-frame-position
-  "Set position of current frame to (X,Y)."
+  "Set position of editor frame to (X,Y)."
   "nFrame X position (pels)\nnFrame Y position (pels)"
   (lambda (x y)
     (win32-screen/set-position! (selected-screen) x y)))
@@ -122,14 +121,14 @@ When called interactively, completion is available on the input."
   ()
   (lambda ()
     (let ((screen (selected-screen)))
-      (call-with-values (lambda () (win32-screen/get-position screen))
-	(lambda (x y r b)
+      (call-with-values (lambda () (win32-screen/get-client-size screen))
+	(lambda (width height)
 	  (message "Frame is "
 		   (screen-x-size screen)
 		   " chars wide and "
 		   (screen-y-size screen)
 		   " chars high ("
-		   (- r x) "x" (- b y)
+		   width "x" height
 		   " pels)"))))))
 
 (define-command show-frame-position