From 0d9a721a1d4a889bb1d79c590d7a6a7c6082153e Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 7 Oct 1996 18:20:31 +0000 Subject: [PATCH] Implement M-x set-frame-size. Fix bug in M-x show-frame-size. --- v7/src/edwin/edwin.pkg | 16 ++++- v7/src/edwin/win32.scm | 132 ++++++++++++++++++++------------------ v7/src/edwin/win32com.scm | 21 +++--- 3 files changed, 93 insertions(+), 76 deletions(-) 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 -- 2.25.1