;;; -*-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
;;;
(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)
(define win32-screens '())
-
;;(define (debug . details)
;; (pp details console-output-port))
(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))
-
-
+\f
(define (make-win32-screen)
(let* ((window (win32-screen-create! 0 win32-screen-features-mask))
(icon (load-icon (get-handle 0) "EDWIN_ICON"))
;;(debug 'CREATE screen)
screen)))
-
(define (win32-screen/beep screen)
screen
(message-beep -1))
(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)
(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))
-
-
+\f
(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)
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)
(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))
(update-win32-screen-name! screen)
(set-screen-redisplay-title?! screen false)))
(win32-screen/flush! screen)))))
-
+\f
(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)
(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))
(define (handle->win32-screen handle)
(list-search-positive win32-screens
(lambda (screen) (eqv? handle (state/handle (screen-state screen))))))
-
-
+\f
(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?
(define (with-win32-interrupts-disabled thunk)
(with-signal-interrupts false thunk))
-
+
(define (with-signal-interrupts enabled? thunk)
(let ((old))
(dynamic-wind (lambda ()
(^G-signal))
(define signal-interrupts? #f)
-
+\f
(define-integrable (some-bits? mask item)
(not (fix:= 0 (fix:and mask item))))
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
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))
(else
(integer->char key)))))
result)))
-
-
+\f
(define (get-win32-input-operations screen)
screen ; ignored
(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
+\f
+;; 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)
(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)))))))))
-
-
+\f
(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)))
(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))
(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
projects / mit-scheme.git / commitdiff