From: Chris Hanson Date: Mon, 19 Dec 1994 19:46:35 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6863 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=568dbeff35c5cf3a938f1940a7721daf1a48379e;p=mit-scheme.git Initial revision --- diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm new file mode 100644 index 000000000..19787fa94 --- /dev/null +++ b/v7/src/edwin/os2.scm @@ -0,0 +1,424 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: os2.scm,v 1.1 1994/12/19 19:44:12 cph Exp $ +;;; +;;; Copyright (c) 1994 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; +;;; NOTE: Parts of this program (Edwin) were created by translation +;;; from corresponding parts of GNU Emacs. Users should be aware that +;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy +;;; of that license should have been included along with this file. + +;;;; OS/2 Customizations for Edwin + +(declare (usual-integrations)) + +(define-variable version-control + "Control use of version numbers for backup files. +#T means make numeric backup versions unconditionally. +#F means make them for files that have some already. +'NEVER means do not make them." + #f + (lambda (object) (or (eq? object 'NEVER) (boolean? object)))) + +(define-variable kept-old-versions + "Number of oldest versions to keep when a new numbered backup is made." + 2 + exact-nonnegative-integer?) + +(define-variable kept-new-versions + "Number of newest versions to keep when a new numbered backup is made. +Includes the new backup. Must be > 0." + 2 + (lambda (n) (and (exact-integer? n) (> n 0)))) + +(define-variable completion-ignored-extensions + "Completion ignores filenames ending in any string in this list." + (list ".bin" ".com" ".ext" + ".inf" ".bif" ".bsm" ".bci" ".bcs" + ".psb" ".moc" ".fni" + ".bco" ".bld" ".bad" ".glo" ".fre" + ".obj" ".exe" ".pif" ".grp" + ".dvi" ".toc" ".log" ".aux") + (lambda (extensions) + (and (list? extensions) + (for-all? extensions + (lambda (extension) + (and (string? extension) + (not (string-null? extension)))))))) + +;;;; Filename I/O + +(define (os/trim-pathname-string string) + (let ((end (string-length string)) + (pattern (re-compile-pattern "[\\/]\\([\\/$~]\\|[a-zA-Z]:\\)" #t))) + (let loop ((start 0)) + (cond ((re-search-substring-forward pattern #t #f string start end) + (loop (re-match-start-index 1))) + ((fix:= start 0) string) + (else (string-tail string start)))))) + +(define (os/pathname->display-string pathname) + (let ((pathname (enough-pathname pathname (user-homedir-pathname)))) + (if (pathname-absolute? pathname) + (->namestring pathname) + (string-append "~\\" (->namestring pathname))))) + +(define (os/truncate-filename-for-modeline filename width) + (let ((length (string-length filename))) + (if (< 0 width length) + (let ((result + (substring + filename + (let ((index (- length width))) + (if (char=? #\\ (string-ref filename index)) + index + (or (substring-find-next-char filename index length #\\) + (fix:+ index 1)))) + length))) + (string-set! result 0 #\$) + result) + filename))) + +;;;; Backup and Auto-Save Filenames + +(define (os/buffer-backup-pathname truename) + (if (eq? 'NEVER (ref-variable version-control)) + (values (os2/make-backup-pathname truename #f) '()) + (let ((prefix + (if (os2/fs-long-filenames? truename) + (string-append (file-namestring truename) ".~") + (string-append (pathname-name truename) ".")))) + (let ((versions + (let loop + ((filenames + (os/directory-list-completions + (directory-namestring truename) + prefix)) + (versions '())) + (if (null? filenames) + (sort versions <) + (loop (cdr filenames) + (let ((version + (os/numeric-backup-filename? + (car filenames)))) + (if (and version (> version 0)) + (cons version versions) + versions))))))) + (if (null? versions) + (values (os2/make-backup-pathname + truename + (and (ref-variable version-control) + 1)) + '()) + (values (os2/make-backup-pathname truename + (+ (apply max versions) 1)) + (let ((start (ref-variable kept-old-versions)) + (end + (- (length versions) + (- (ref-variable kept-new-versions) 1)))) + (if (< start end) + (map (lambda (version) + (os2/make-backup-pathname truename + version)) + (sublist versions start end)) + '())))))))) + +(define (os2/make-backup-pathname pathname version) + (if (os2/fs-long-filenames? pathname) + (string-append (->namestring pathname) + (if version + (string-append ".~" (number->string version) "~") + "~")) + (pathname-new-type pathname + (if (and version (< version 1000)) + (let ((type (pathname-type pathname)) + (vs (number->string version))) + (if (and (< version 100) + (string? type) + (not (string-null? type))) + (string-append (substring type 0 1) + (string-pad-left vs 2 #\0)) + (string-pad-left vs 3 #\0))) + "bak")))) + +(define (os/default-backup-filename) + "$TMP\\edwin.bak") + +(define (os/backup-filename? filename) + (or (string-suffix? "~" filename) + (let ((type (pathname-type filename))) + (and (string? type) + (or (string-ci=? "bak" type) + (re-match-string-forward (re-compile-pattern ".[0-9][0-9]" #f) + #f + #f + type)))))) + +(define (os/numeric-backup-filename? filename) + (let ((version + (or (and (re-search-string-forward + (re-compile-pattern "\\.~\\([0-9]+\\)~$" #f) + #f + #f + filename) + (substring->number filename + (re-match-start-index 1) + (re-match-end-index 1))) + (let ((type (pathname-type filename))) + (and (string? type) + (fix:= 3 (string-length type)) + (or (substring->number type 0 3) + (substring->number type 1 3))))))) + (and version + (> version 0) + version))) + +(define (os/auto-save-pathname pathname buffer) + (let ((pathname + (or pathname + (let ((name (buffer-name buffer)) + (directory (buffer-default-directory buffer))) + (merge-pathnames (if (os2/fs-long-filenames? directory) + (string-append "%" name) + "%buffer%") + directory))))) + (if (os2/fs-long-filenames? pathname) + (merge-pathnames (string-append "#" (file-namestring pathname) "#") + (directory-pathname pathname)) + (pathname-new-type pathname "sav")))) + +(define (os/auto-save-filename? filename) + (or (re-match-string-forward (re-compile-pattern "^#.+#$" #f) + #f + #f + (file-namestring filename)) + (let ((type (pathname-type filename))) + (and (string? type) + (string-ci=? "sav" type))))) + +(define (os/precious-backup-pathname pathname) + (if (os2/fs-long-filenames? pathname) + (let ((directory (directory-pathname pathname))) + (let loop ((i 0)) + (let ((pathname + (merge-pathnames (string-append "#tmp#" (number->string i)) + directory))) + (if (allocate-temporary-file pathname) + pathname + (loop (+ i 1)))))) + (os/auto-save-pathname pathname #f))) + +(define (os2/fs-long-filenames? pathname) + (let ((type ((ucode-primitive drive-type 1) (pathname-device pathname)))) + (or (string-ci=? "hpfs" type) + (string-ci=? "nfs" type)))) + +;;;; Miscellaneous + +(define (os/backup-buffer? truename) + (let ((attrs (file-attributes truename))) + (and attrs + (eq? #f (file-attributes/type attrs))))) + +(define (os/backup-by-copying? truename buffer) + truename buffer + #f) + +(define os/pathname-type-for-mode + pathname-type) + +(define (os/completion-ignore-filename? filename) + (or (os/backup-filename? filename) + (os/auto-save-filename? filename) + (and (not (os/file-directory? filename)) + (there-exists? (ref-variable completion-ignored-extensions) + (lambda (extension) + (string-suffix? extension filename)))))) + +(define (os/file-type-to-major-mode) + (alist-copy + `(("asm" . midas) + ("bat" . text) + ("bib" . text) + ("c" . c) + ("h" . c) + ("m4" . midas) + ("pas" . pascal) + ("s" . scheme) + ("scm" . scheme) + ("txi" . texinfo) + ("txt" . text)))) + +(define (os/init-file-name) + (let ((name "edwin.ini")) + (let ((user-init-file (merge-pathnames name (user-homedir-pathname)))) + (if (file-exists? user-init-file) + user-init-file + (merge-pathnames name (system-library-directory-pathname #f)))))) + +(define (os/find-file-initialization-filename pathname) + (or (and (equal? "scm" (pathname-type pathname)) + (let ((pathname (pathname-new-type pathname "ffi"))) + (and (file-exists? pathname) + pathname))) + (let ((pathname + (merge-pathnames "edwin.ffi" (directory-pathname pathname)))) + (and (file-exists? pathname) + pathname)))) + +(define (os/read-file-methods) '()) + +(define (os/write-file-methods) '()) + +(define (os/scheme-can-quit?) + #f) + +(define (os/quit dir) + dir + (error "Can't quit.")) + +(define (os/set-file-modes-writable! pathname) + (set-file-modes! pathname (fix:andc (file-modes pathname) #x0001))) + +;;;; Dired customization + +(define-variable dired-listing-switches + "Dired listing format." + "-l" + string?) + +(define-variable list-directory-brief-switches + "list-directory brief listing format." + "" + string?) + +(define-variable list-directory-verbose-switches + "list-directory verbose listing format." + "-l" + string?) + +(define (insert-directory! file switches mark type) + ;; Insert directory listing for FILE at MARK. + ;; TYPE can have one of three values: + ;; 'WILDCARD means treat FILE as shell wildcard. + ;; 'DIRECTORY means FILE is a directory and a full listing is expected. + ;; 'FILE means FILE itself should be listed, and not its contents. + ;; SWITCHES are examined for the presence of "t". + (for-each + (let ((nmonths + (lambda (time) + (let ((time (quotient time #x200000))) + (+ (* (quotient time 16) 12) (remainder time 16)))))) + (let ((now (nmonths (os2/current-file-time)))) + (lambda (entry) + (let ((string + (let ((name (car entry)) + (attr (cdr entry))) + (let ((time (file-attributes/modification-time attr))) + (let ((time-string (os2/file-time->string time))) + (string-append + (file-attributes/mode-string attr) + " " + (string-pad-left (number->string + (file-attributes/length attr)) + 10 #\Space) + " " + (substring time-string 0 6) ;month/day + " " + (if (<= -6 (- (nmonths time) now) 0) + (substring time-string 7 12) ;hour/minute + (substring time-string 15 20)) ;year + " " + name)))))) + (let ((mark (mark-left-inserting-copy mark))) + (insert-string string mark) + (insert-newline mark) + (mark-temporary! mark)))))) + (let ((pathname + (if (eq? 'DIRECTORY type) (pathname-as-directory file) file)) + (read + (lambda (pathname sort?) + (list-transform-positive + (map (lambda (pathname) + (cons (file-namestring pathname) + (file-attributes pathname))) + (directory-read pathname sort?)) + cdr)))) + (if (string-find-next-char switches #\t) + (sort (read pathname #f) + (lambda (x y) + (> (file-attributes/modification-time (cdr x)) + (file-attributes/modification-time (cdr y))))) + (read pathname #t))))) + +;;;; Generic Stuff +;;; These definitions are OS-independent and references to them should +;;; be replaced in order to reduce the number of OS-dependent defs. + +(define (os/directory-list directory) + (let ((channel (directory-channel-open directory))) + (let loop ((result '())) + (let ((name (directory-channel-read channel))) + (if name + (loop (cons name result)) + (begin + (directory-channel-close channel) + result)))))) + +(define (os/directory-list-completions directory prefix) + (let ((channel (directory-channel-open directory))) + (let loop ((result '())) + (let ((name (directory-channel-read-matching channel prefix))) + (if name + (loop (cons name result)) + (begin + (directory-channel-close channel) + result)))))) + +(define os/file-directory? + file-directory?) + +(define-integrable (os/make-filename directory filename) + (->namestring (merge-pathnames filename directory))) + +(define-integrable (os/filename-as-directory filename) + (->namestring (pathname-as-directory filename))) + +(define os/filename-non-directory + file-namestring) + +(define os/filename->display-string + os/pathname->display-string) \ No newline at end of file diff --git a/v7/src/edwin/os2com.scm b/v7/src/edwin/os2com.scm new file mode 100644 index 000000000..aa09311a2 --- /dev/null +++ b/v7/src/edwin/os2com.scm @@ -0,0 +1,123 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: os2com.scm,v 1.1 1994/12/19 19:46:35 cph Exp $ +;;; +;;; Copyright (c) 1994 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; +;;; NOTE: Parts of this program (Edwin) were created by translation +;;; from corresponding parts of GNU Emacs. Users should be aware that +;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy +;;; of that license should have been included along with this file. + +;;;; OS/2 Presentation Manager Commands + +(declare (usual-integrations)) + +(define-command set-foreground-color + "Set foreground (text) color to COLOR." + "sSet foreground color" + (lambda (name) + (let ((screen (selected-screen))) + (os2-screen/set-foreground-color! screen (name->color name)) + (update-screen! screen #t)))) + +(define-command set-background-color + "Set background (text) color to COLOR." + "sSet background color" + (lambda (name) + (let ((screen (selected-screen))) + (os2-screen/set-background-color! screen (name->color name)) + (update-screen! screen #t)))) + +(define (name->color name) + (let ((length (string-length name))) + (if (and (not (fix:= 0 length)) + (char=? #\# (string-ref name 0))) + (let ((color + (and (fix:= 7 length) + (let ((color (substring->number name 1 length 16))) + (and color + (fix:>= color 0) + color))))) + (if (not color) + (editor-error "Ill-formed RGB color name:" name)) + color) + (editor-error "Unknown color name:" name)))) + +(define-command set-font + "Set font to be used for drawing text." + "sSet font" + (lambda (font) + (let ((screen (selected-screen))) + (os2-screen/set-font! screen font) + (update-screen! screen #t)))) + +(define-command set-screen-size + "Set size of editor screen to WIDTH x HEIGHT." + "nScreen width (chars)\nnScreen height (chars)" + (lambda (width height) + (os2-screen/set-size! (selected-screen) (max 2 width) (max 2 height)))) + +(define-command set-screen-position + "Set position of editor screen to (X,Y)." + "nX position (pels)\nnY position (pels)" + (lambda (x y) + (os2-screen/set-position! (selected-screen) x y))) + +(define-command show-screen-size + "Show size of editor screen." + () + (lambda () + (let ((screen (selected-screen))) + (message "Screen is " + (screen-x-size screen) + " chars wide and " + (screen-y-size screen) + " chars high (" + (screen-pel-width screen) + "x" + (screen-pel-height screen) + " pels)")))) + +(define-command show-screen-position + "Show position of editor screen. +This is the position of the lower left-hand corner of the frame border +surrounding the screen, relative to the lower left-hand corner of the +desktop." + () + (lambda () + (call-with-values (lambda () (os2-screen/get-position (selected-screen))) + (lambda (x y) + (message "Screen's lower left-hand corner is at (" x "," y ")"))))) \ No newline at end of file diff --git a/v7/src/edwin/os2term.scm b/v7/src/edwin/os2term.scm new file mode 100644 index 000000000..91b9662cb --- /dev/null +++ b/v7/src/edwin/os2term.scm @@ -0,0 +1,1082 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: os2term.scm,v 1.1 1994/12/19 19:46:29 cph Exp $ +;;; +;;; Copyright (c) 1994 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of +;;; Electrical Engineering and Computer Science. Permission to +;;; copy this software, to redistribute it, and to use it for any +;;; purpose is granted, subject to the following restrictions and +;;; understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) +;;; to return to the MIT Scheme project any improvements or +;;; extensions that they make, so that these may be included in +;;; future releases; and (b) to inform MIT of noteworthy uses of +;;; this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with +;;; the usual standards of acknowledging credit in academic +;;; research. +;;; +;;; 4. MIT has made no warrantee or representation that the +;;; operation of this software will be error-free, and MIT is +;;; under no obligation to provide any services, by way of +;;; maintenance, update, or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the +;;; Massachusetts Institute of Technology nor of any adaptation +;;; thereof in any advertising, promotional, or sales literature +;;; without prior written consent from MIT in each case. +;;; +;;; NOTE: Parts of this program (Edwin) were created by translation +;;; from corresponding parts of GNU Emacs. Users should be aware that +;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy +;;; of that license should have been included along with this file. + +;;;; OS/2 Presentation Manager Interface +;;; Package: (edwin screen os2-screen) + +(declare (usual-integrations)) + +(define os2-display-type) +(define screen-list) +(define event-queue) +(define virtual-key-table) +(define signal-interrupts?) +(define event-descriptor) +(define previewer-registration) +(define reading-event?) +(define desktop-width) +(define desktop-height) + +(define (initialize-package!) + (set! os2-display-type + (make-display-type 'PM + #t + (lambda () #t) + make-os2-screen + get-os2-input-operations + with-editor-interrupts-from-os2 + with-os2-interrupts-enabled + with-os2-interrupts-disabled)) + (set! screen-list '()) + (set! event-queue (make-queue)) + (set! virtual-key-table (make-virtual-key-table)) + (set! event-descriptor (os2win-event-descriptor)) + unspecific) + +(define (with-editor-interrupts-from-os2 receiver) + (fluid-let ((reading-event? #f) + (signal-interrupts? #t) + (previewer-registration)) + (dynamic-wind (lambda () + (preview-event-stream) + (set! desktop-width (os2win-desktop-width)) + (set! desktop-height (os2win-desktop-height)) + (os2win-set-state (os2win-console-wid) window-state:hide)) + (lambda () + (receiver (lambda (thunk) (thunk)) '())) + (lambda () + (deregister-input-thread-event previewer-registration))))) + +(define (with-os2-interrupts-enabled thunk) + (with-signal-interrupts #t thunk)) + +(define (with-os2-interrupts-disabled thunk) + (with-signal-interrupts #f thunk)) + +(define (with-signal-interrupts enabled? thunk) + (let ((old)) + (dynamic-wind (lambda () + (set! old signal-interrupts?) + (set! signal-interrupts? enabled?) + unspecific) + thunk + (lambda () + (set! enabled? signal-interrupts?) + (set! signal-interrupts? old) + unspecific)))) + +(define (make-os2-screen) + (call-with-values open-window + (lambda (state x-size y-size) + (let ((screen + (make-screen state + os2-screen/beep + os2-screen/clear-line! + os2-screen/clear-rectangle! + os2-screen/clear-screen! + os2-screen/discard! + os2-screen/enter! + os2-screen/exit! + os2-screen/flush! + os2-screen/modeline-event! + #f + os2-screen/scroll-lines-down! + os2-screen/scroll-lines-up! + os2-screen/wrap-update! + os2-screen/write-char! + os2-screen/write-cursor! + os2-screen/write-substring! + 8 + x-size + y-size))) + (set! screen-list (cons screen screen-list)) + screen)))) + +(define (open-window) + (let ((wid (os2win-open "Edwin"))) + (let ((metrics (set-normal-font! wid current-font))) + (os2win-set-colors wid + (face-foreground-color normal-face) + (face-background-color normal-face)) + (os2win-show-cursor wid #t) + (os2win-show wid #t) + (os2win-activate wid) + (let ((w.h (os2win-get-size wid))) + (let ((x-size (fix:quotient (car w.h) (font-metrics/width metrics))) + (y-size (fix:quotient (cdr w.h) (font-metrics/height metrics)))) + (let ((size (fix:* x-size y-size))) + (values (make-screen-state wid + metrics + (car w.h) + (cdr w.h) + (make-string size #\space) + (make-vector size normal-face)) + x-size + y-size))))))) + +(define (os2-screen/beep screen) + screen + (os2win-beep 880 50)) + +(define (os2-screen/clear-line! screen x y first-unused-x) + (let ((start (screen-char-index screen x y)) + (end (screen-char-index screen first-unused-x y)) + (face (screen-normal-face screen))) + (substring-fill! (screen-char-map screen) start end #\space) + (subvector-fill! (screen-face-map screen) start end face) + (set-screen-face! screen face)) + (os2win-clear (screen-wid screen) + (cxl->xl screen x) + (cxh->xh screen first-unused-x) + (cyh->yl screen (fix:+ y 1)) + (cyl->yh screen y))) + +(define (os2-screen/clear-rectangle! screen xl xu yl yu highlight) + (if (fix:< xl xu) + (let ((char-map (screen-char-map screen)) + (face-map (screen-face-map screen)) + (face (screen-face screen highlight)) + (x-size (screen-x-size screen)) + (width (fix:- xu xl))) + (do ((y yl (fix:+ y 1)) + (start (screen-char-index screen xl yl) (fix:+ start x-size))) + ((fix:= y yu)) + (let ((end (fix:+ start width))) + (substring-fill! char-map start end #\space) + (subvector-fill! face-map start end face))) + (set-screen-face! screen face) + (os2win-clear (screen-wid screen) + (cxl->xl screen xl) (cxh->xh screen xu) + (cyh->yl screen yu) (cyl->yh screen yl))))) + +(define (os2-screen/clear-screen! screen) + (let ((face (screen-normal-face screen))) + (string-fill! (screen-char-map screen) #\space) + (vector-fill! (screen-face-map screen) face) + (set-screen-face! screen face)) + (os2win-clear (screen-wid screen) + 0 (screen-pel-width screen) + 0 (screen-pel-height screen))) + +(define (os2-screen/discard! screen) + (set! screen-list (delq! screen screen-list)) + (os2win-close (screen-wid screen))) + +(define (os2-screen/enter! screen) + screen + unspecific) + +(define (os2-screen/exit! screen) + screen + unspecific) + +(define (os2-screen/flush! screen) + screen + unspecific) + +(define (os2-screen/modeline-event! screen window type) + screen window type + unspecific) + +(define (os2-screen/wrap-update! screen thunk) + screen + (thunk)) + +(define (os2-screen/write-cursor! screen x y) + (os2win-move-cursor (screen-wid screen) (cx->x screen x) (cy->y screen y))) + +(define (os2-screen/write-char! screen x y char highlight) + (let ((char-map (screen-char-map screen)) + (index (screen-char-index screen x y)) + (face (screen-face screen highlight))) + (string-set! char-map index char) + (vector-set! (screen-face-map screen) index face) + (set-screen-face! screen face) + (os2win-write (screen-wid screen) + (cx->x screen x) + (fix:+ (cy->y screen y) (screen-char-descender screen)) + char-map + index + (fix:+ index 1)))) + +(define (os2-screen/write-substring! screen x y string start end highlight) + (let ((start* (screen-char-index screen x y)) + (face (screen-face screen highlight))) + (%substring-move! string start end (screen-char-map screen) start*) + (subvector-fill! (screen-face-map screen) + start* + (fix:+ start* (fix:- end start)) + face) + (set-screen-face! screen face) + (os2win-write (screen-wid screen) + (cx->x screen x) + (fix:+ (cy->y screen y) (screen-char-descender screen)) + string start end))) + +(define use-scrolling? #t) + +(define (os2-screen/scroll-lines-down! screen xl xu yl yu amount) + (and use-scrolling? + (begin + (let ((char-map (screen-char-map screen)) + (face-map (screen-face-map screen)) + (x-size (screen-x-size screen)) + (width (fix:- xu xl)) + (y-from (fix:- yu amount))) + (if (fix:= x-size width) + (let ((start (fix:* x-size yl)) + (end (fix:* x-size y-from)) + (start* (fix:* x-size (fix:+ yl amount)))) + (%substring-move! char-map start end char-map start*) + (subvector-move-right! face-map start end face-map start*)) + (let ((delta (fix:* x-size amount)) + (end (screen-char-index screen xl (fix:- yl 1)))) + (do ((from (screen-char-index screen xl (fix:- y-from 1)) + (fix:- from x-size))) + ((fix:= from end)) + (let ((from-end (fix:+ from width)) + (to (fix:+ from delta))) + (%substring-move! char-map from from-end char-map to) + (subvector-move-right! face-map from from-end + face-map to)))))) + (os2win-scroll (screen-wid screen) + (cxl->xl screen xl) + (cxh->xh screen xu) + (cyh->yl screen (fix:- yu amount)) + (cyl->yh screen yl) + 0 + (fix:- 0 (fix:* amount (screen-char-height screen)))) + 'UNCHANGED))) + +(define (os2-screen/scroll-lines-up! screen xl xu yl yu amount) + (and use-scrolling? + (begin + (let ((char-map (screen-char-map screen)) + (face-map (screen-face-map screen)) + (x-size (screen-x-size screen)) + (width (fix:- xu xl)) + (y-from (fix:+ yl amount))) + (if (fix:= x-size width) + (let ((start (fix:* x-size y-from)) + (end (fix:* x-size yu)) + (start* (fix:* x-size yl))) + (%substring-move! char-map start end char-map start*) + (subvector-move-left! face-map start end face-map start*)) + (let ((delta (fix:* x-size amount)) + (end (screen-char-index screen xl yu))) + (do ((from (screen-char-index screen xl y-from) + (fix:+ from x-size))) + ((fix:= from end)) + (let ((from-end (fix:+ from width)) + (to (fix:- from delta))) + (%substring-move! char-map from from-end char-map to) + (subvector-move-left! face-map from from-end + face-map to)))))) + (os2win-scroll (screen-wid screen) + (cxl->xl screen xl) + (cxh->xh screen xu) + (cyh->yl screen yu) + (cyl->yh screen (fix:+ yl amount)) + 0 + (fix:* amount (screen-char-height screen))) + 'UNCHANGED))) + +(define-integrable (screen-face screen highlight) + (if highlight + (screen-highlight-face screen) + (screen-normal-face screen))) + +(define (set-screen-face! screen face) + (if (not (eq? face (screen-current-face screen))) + (begin + (os2win-set-colors (screen-wid screen) + (face-foreground-color face) + (face-background-color face)) + (set-screen-current-face! screen face)))) + +(define-structure face + (foreground-color #f read-only #t) + (background-color #f read-only #t)) + +(define current-font "4.System VIO") +(define normal-face (make-face #x000000 #xFFFFFF)) +(define highlight-face (make-face #xFFFFFF #x000000)) + +(define-integrable (screen-normal-face screen) screen normal-face) +(define-integrable (screen-highlight-face screen) screen highlight-face) + +(define (os2-screen/set-foreground-color! screen color) + screen + (set! normal-face + (make-face color (face-background-color normal-face))) + (set! highlight-face + (make-face (face-foreground-color highlight-face) color)) + unspecific) + +(define (os2-screen/set-background-color! screen color) + screen + (set! normal-face + (make-face (face-foreground-color normal-face) color)) + (set! highlight-face + (make-face color (face-background-color highlight-face))) + unspecific) + +(define (os2-screen/set-font! screen font) + (set-screen-font-metrics! screen (set-normal-font! (screen-wid screen) font)) + (set! current-font font) + (let ((resize (screen-resize-thunk screen))) + (if resize + (resize)))) + +(define (set-normal-font! wid font) + (let ((metrics (os2win-set-font wid 1 font))) + (if (not metrics) + (error "Unknown font name:" font)) + (let ((width (font-metrics/width metrics)) + (height (font-metrics/height metrics))) + (os2win-set-grid wid width height) + (os2win-shape-cursor wid width height + (fix:or CURSOR_SOLID CURSOR_FLASH))) + metrics)) + +(define (os2-screen/set-size! screen x-size y-size) + (os2win-set-size (screen-wid screen) + (fix:* x-size (screen-char-width screen)) + (fix:* y-size (screen-char-height screen)))) + +(define (os2-screen/get-position screen) + (let ((x.y (os2win-get-pos (screen-wid screen)))) + (values (car x.y) + (cdr x.y)))) + +(define (os2-screen/set-position! screen x y) + (os2win-set-pos (screen-wid screen) x y)) + +(define (os2-screen/raise! screen) + (os2win-set-state (screen-wid screen) window-state:top)) + +(define (os2-screen/lower! screen) + (os2win-set-state (screen-wid screen) window-state:bottom)) + +(define (os2-screen/hide! screen) + (os2win-set-state (screen-wid screen) window-state:hide)) + +(define (os2-screen/minimize! screen) + (os2win-set-state (screen-wid screen) window-state:minimize)) + +(define (os2-screen/maximize! screen) + (os2win-set-state (screen-wid screen) window-state:maximize)) + +(define (os2-screen/restore! screen) + (os2win-set-state (screen-wid screen) window-state:restore)) + +(define (os2/desktop-width) + desktop-width) + +(define (os2/desktop-height) + desktop-height) + +(define-integrable (cx->x screen cx) + ;; Returns leftmost pel of cell. + (fix:* cx (screen-char-width screen))) + +(define-integrable (cy->y screen cy) + ;; Returns bottommost pel of cell. + (cyl->yh screen (fix:+ cy 1))) + +(define-integrable (cyl->yh screen cy) + ;; Returns bottommost pel of cell above. + (fix:* (fix:- (screen-y-size screen) cy) (screen-char-height screen))) + +(define-integrable cxl->xl cx->x) +(define-integrable cxh->xh cx->x) +(define-integrable cyh->yl cyl->yh) + +(define (x->cx screen x) + (let ((cx (fix:quotient x (screen-char-width screen))) + (xs (screen-x-size screen))) + (if (fix:> cx xs) + xs + cx))) + +(define (y->cy screen y) + (let ((cy + (fix:- (fix:- (screen-y-size screen) 1) + (fix:quotient y (screen-char-height screen))))) + (if (fix:< cy 0) + 0 + cy))) + +(define (xl->cxl screen xl) + (let ((cx (fix:quotient xl (screen-char-width screen))) + (xs (screen-x-size screen))) + (if (fix:> cx xs) + xs + cx))) + +(define (xh->cxh screen xh) + (let ((cx + (let ((cw (screen-char-width screen))) + (let ((cx (fix:quotient xh cw))) + (if (fix:= 0 (fix:remainder xh cw)) + cx + (fix:+ cx 1))))) + (xs (screen-x-size screen))) + (if (fix:> cx xs) + xs + cx))) + +(define (yl->cyh screen yl) + (let ((cy + (fix:- (screen-y-size screen) + (fix:quotient yl (screen-char-height screen))))) + (if (fix:< cy 0) + 0 + cy))) + +(define (yh->cyl screen yh) + (let ((cy + (let ((ch (screen-char-height screen))) + (let ((cy (fix:- (screen-y-size screen) (fix:quotient yh ch)))) + (if (fix:= 0 (fix:remainder yh ch)) + cy + (fix:- cy 1)))))) + (if (fix:< cy 0) + 0 + cy))) + +(define-integrable (width->x-size screen width) + (fix:quotient width (screen-char-width screen))) + +(define-integrable (height->y-size screen height) + (fix:quotient height (screen-char-height screen))) + +(define-structure (os2-screen-state + (constructor + make-screen-state + (wid font-metrics pel-width pel-height char-map face-map)) + (predicate screen-state?) + (conc-name screen-state/)) + (wid #f read-only #t) + font-metrics + (pel-width 0) + (pel-height 0) + (char-map "") + (face-map '#()) + (current-face normal-face)) + +(define-integrable (screen-wid screen) + (screen-state/wid (screen-state screen))) + +(define-integrable (screen-font-metrics screen) + (screen-state/font-metrics (screen-state screen))) + +(define-integrable (set-screen-font-metrics! screen metrics) + (set-screen-state/font-metrics! (screen-state screen) metrics)) + +(define-integrable (screen-pel-width screen) + (screen-state/pel-width (screen-state screen))) + +(define-integrable (set-screen-pel-width! screen width) + (set-screen-state/pel-width! (screen-state screen) width)) + +(define-integrable (screen-pel-height screen) + (screen-state/pel-height (screen-state screen))) + +(define-integrable (set-screen-pel-height! screen height) + (set-screen-state/pel-height! (screen-state screen) height)) + +(define-integrable (screen-char-map screen) + (screen-state/char-map (screen-state screen))) + +(define-integrable (set-screen-char-map! screen char-map) + (set-screen-state/char-map! (screen-state screen) char-map)) + +(define-integrable (screen-face-map screen) + (screen-state/face-map (screen-state screen))) + +(define-integrable (set-screen-face-map! screen face-map) + (set-screen-state/face-map! (screen-state screen) face-map)) + +(define-integrable (screen-current-face screen) + (screen-state/current-face (screen-state screen))) + +(define-integrable (set-screen-current-face! screen face) + (set-screen-state/current-face! (screen-state screen) face)) + +(define-structure (font-metrics (type vector) (conc-name font-metrics/)) + (width #f read-only #t) + (height #f read-only #t) + (descender #f read-only #t)) + +(define-integrable (screen-char-width screen) + (font-metrics/width (screen-font-metrics screen))) + +(define-integrable (screen-char-height screen) + (font-metrics/height (screen-font-metrics screen))) + +(define-integrable (screen-char-descender screen) + (font-metrics/descender (screen-font-metrics screen))) + +(define-integrable (screen-char-index screen x y) + (fix:+ (fix:* y (screen-x-size screen)) x)) + +(define (wid->screen wid) + (let loop ((screens screen-list)) + (and (not (null? screens)) + (if (fix:= wid (screen-wid (car screens))) + (car screens) + (loop (cdr screens)))))) + +(define (get-os2-input-operations screen) + screen + (let ((pending #f) + (repeat 0)) + + (define (halt-update?) + (setup-pending 'IN-UPDATE) + pending) + + (define (peek-no-hang) + (setup-pending #f) + pending) + + (define (peek) + (setup-pending #t) + pending) + + (define (read) + (setup-pending #t) + (let ((result pending)) + (if (fix:> repeat 1) + (set! repeat (fix:- repeat 1)) + (set! pending #f)) + result)) + + (define (setup-pending block?) + (if (not pending) + (let loop () + (let ((event (read-event block?))) + (cond ((not event) + (set! pending #f)) + ((not (vector? event)) + (let ((flag (process-change-event event))) + (if flag + (begin + (set! pending + (make-input-event + (if (eq? flag 'FORCE-RETURN) + 'RETURN + 'UPDATE) + update-screens! + #f)) + (set! repeat 1)) + (loop)))) + ((fix:= event-type:key (event-type event)) + (set! pending (translate-key-event event)) + (set! repeat (key-event/repeat event)) + (cond ((fix:= 0 repeat) + (set! pending #f)) + ((and (char? pending) + (char=? pending #\BEL) + signal-interrupts?) + (set! pending #f) + (signal-interrupt!))) + (if (not pending) + (loop))) + (else + (set! pending (process-special-event event)) + (if pending + (set! repeat 1) + (loop)))))))) + + (values halt-update? peek-no-hang peek read))) + +(define (read-event block?) + (let loop () + (set! reading-event? #t) + (let ((event + (if (queue-empty? event-queue) + (if (eq? 'IN-UPDATE block?) + (os2win-get-event #f) + (read-event-1 block?)) + (dequeue!/unsafe event-queue)))) + (set! reading-event? #f) + (if (and (vector? event) + (fix:= (vector-ref event 0) event-type:paint)) + (begin + (process-paint-event event) + (loop)) + event)))) + +(define (read-event-1 block?) + (or (os2win-get-event #f) + (let loop () + (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (cond (inferior-thread-changes? + (set-interrupt-enables! interrupt-mask) + event:inferior-thread-output) + (else + (let ((flag + (test-for-input-on-descriptor event-descriptor + block?))) + (set-interrupt-enables! interrupt-mask) + (case flag + ((#F) #f) + ((PROCESS-STATUS-CHANGE) event:process-status) + ((INTERRUPT) (loop)) + (else (read-event-1 block?)))))))))) + +(define (preview-event-stream) + (set! previewer-registration + (permanently-register-input-thread-event + event-descriptor + (current-thread) + (lambda () + (if (not reading-event?) + (let ((event (os2win-get-event #f))) + (if event + (if (and signal-interrupts? + (vector? event) + (fix:= event-type:key (event-type event)) + ;; This tests for CTRL on, ALT off, and + ;; not a virtual key: + (fix:= #x10 + (fix:and #x32 (key-event/flags event))) + (let ((code (key-event/code event))) + (or (fix:= code (char->integer #\G)) + (fix:= code (char->integer #\g))))) + (begin + (clean-event-queue event-queue) + (signal-interrupt!)) + (enqueue!/unsafe event-queue event)))))))) + unspecific) + +(define (clean-event-queue queue) + ;; Flush keyboard and mouse events from the input queue. Other + ;; events are harmless and must be processed regardless. + (do ((events (let loop () + (if (queue-empty? queue) + '() + (let ((event (dequeue!/unsafe queue))) + (if (and (vector? event) + (let ((type (event-type event))) + (or (fix:= type event-type:button) + (fix:= type event-type:key)))) + (loop) + (cons event (loop)))))) + (cdr events))) + ((null? events)) + (enqueue!/unsafe queue (car events)))) + +(define (signal-interrupt!) + (editor-beep) + (temporary-message "Quit") + (^G-signal)) + +(define (translate-key-event event) + (let ((code (key-event/code event)) + (flags (key-event/flags event))) + (let ((control (if (fix:= 0 (fix:and flags KC_CTRL)) 0 2)) + (meta (if (fix:= 0 (fix:and flags KC_ALT)) 0 1))) + (let ((process-code + (lambda (code) + (if (and (fix:<= #o040 code) (not (fix:= 0 control))) + (make-char (fix:and code #o037) meta) + (make-char code (fix:or meta control)))))) + (if (fix:= 0 (fix:and flags KC_VIRTUALKEY)) + (and (fix:< code #o200) + (process-code code)) + (let ((key + (and (fix:< code (vector-length virtual-key-table)) + (vector-ref virtual-key-table code)))) + (and key + (if (fix:fixnum? key) + (process-code key) + (make-special-key key (fix:or meta control)))))))))) + +(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 (process-paint-event event) + (let ((wid (event-wid event))) + (let ((screen (wid->screen wid))) + (if screen + (let ((cxl (xl->cxl screen (paint-event/xl event))) + (cxh (xh->cxh screen (paint-event/xh event))) + (cyl (yh->cyl screen (paint-event/yh event))) + (cyh (yl->cyh screen (paint-event/yl event))) + (char-map (screen-char-map screen)) + (face-map (screen-face-map screen)) + (x-size (screen-x-size screen)) + (char-height (screen-char-height screen))) + (if (fix:< cxl cxh) + (let ((size (fix:- cxh cxl))) + (do ((cy cyl (fix:+ cy 1)) + (y (fix:+ (cy->y screen cyl) + (screen-char-descender screen)) + (fix:- y char-height)) + (start (screen-char-index screen cxl cyl) + (fix:+ start x-size))) + ((fix:= cy cyh)) + (let ((end (fix:+ start size))) + (let outer ((start start) (cxl cxl)) + (let ((face (vector-ref face-map start))) + (let inner ((index (fix:+ start 1))) + (if (or (fix:= index end) + (not (eq? face + (vector-ref face-map index)))) + (begin + (set-screen-face! screen face) + (os2win-write wid (cx->x screen cxl) y + char-map start end) + (if (not (fix:= index end)) + (outer index + (fix:+ cxl (fix:- index start))))) + (inner (fix:+ index 1))))))))))))))) + +(define (process-special-event event) + (let ((handler (vector-ref event-handlers (event-type event))) + (screen (wid->screen (event-wid event)))) + (and handler + screen + (handler screen event)))) + +(define event-handlers + (make-vector number-of-event-types false)) + +(define-integrable (define-event-handler event-type handler) + (vector-set! event-handlers event-type handler)) + +(define-event-handler event-type:button + (lambda (screen event) + (and (eq? button-event-type:down (button-event/type event)) + (if (os2win-focus? (screen-wid screen)) + (make-input-event 'BUTTON + execute-button-command + screen + (make-down-button (button-event/number event)) + (x->cx screen (button-event/x event)) + (y->cy screen (button-event/y event))) + (begin + (os2win-activate (screen-wid screen)) + #f))))) + +(define-event-handler event-type:close + (lambda (screen event) + event + (and (not (screen-deleted? screen)) + (make-input-event 'DELETE-SCREEN delete-screen! screen)))) + +(define-event-handler event-type:focus + (lambda (screen event) + (and (focus-event/gained? event) + (not (selected-screen? screen)) + (make-input-event 'SELECT-SCREEN select-screen screen)))) + +(define-event-handler event-type:resize + (lambda (screen event) + (set-screen-pel-width! screen (resize-event/width event)) + (set-screen-pel-height! screen (resize-event/height event)) + (let ((thunk (screen-resize-thunk screen))) + (and thunk + (make-input-event 'SET-SCREEN-SIZE + (lambda (screen) + (thunk) + (update-screen! screen #t)) + screen))))) + +(define (screen-resize-thunk screen) + (let ((width (screen-pel-width screen)) + (height (screen-pel-height screen))) + (let ((x-size (width->x-size screen width)) + (y-size (height->y-size screen height))) + (and (not (and (= x-size (screen-x-size screen)) + (= y-size (screen-y-size screen)))) + (lambda () + (let ((size (fix:* x-size y-size))) + (set-screen-char-map! screen (make-string size #\space)) + (set-screen-face-map! + screen + (make-vector size (screen-current-face screen)))) + (set-screen-size! screen x-size y-size)))))) + +(define-event-handler event-type:visibility + (lambda (screen event) + (and (not (screen-deleted? screen)) + (if (visibility-event/shown? event) + (begin + (set-screen-visibility! screen 'VISIBLE) ;don't really know + (make-input-event 'UPDATE update-screen! screen #t)) + (begin + (set-screen-visibility! screen 'UNMAPPED) + (and (selected-screen? screen) + (let ((screen (other-screen screen #f))) + (and screen + (make-input-event 'SELECT-SCREEN + select-screen + screen))))))))) + +(define (make-virtual-key-table) + ;; Shift keys are commented out, causing them to be ignored. + (let ((table (make-vector virtual-key-supremum #f))) + (vector-set! table VK_BUTTON1 'BUTTON1) + (vector-set! table VK_BUTTON2 'BUTTON2) + (vector-set! table VK_BUTTON3 'BUTTON3) + (vector-set! table VK_BREAK 'BREAK) + (vector-set! table VK_BACKSPACE (char-code #\rubout)) + (vector-set! table VK_TAB (char-code #\tab)) + (vector-set! table VK_BACKTAB 'BACKTAB) + (vector-set! table VK_NEWLINE (char-code #\return)) + ;;(vector-set! table VK_SHIFT 'SHIFT) + ;;(vector-set! table VK_CTRL 'CTRL) + ;;(vector-set! table VK_ALT 'ALT) + ;;(vector-set! table VK_ALTGRAF 'ALTGRAF) + (vector-set! table VK_PAUSE 'PAUSE) + ;;(vector-set! table VK_CAPSLOCK 'CAPS-LOCK) + (vector-set! table VK_ESC (char-code #\escape)) + (vector-set! table VK_SPACE (char-code #\space)) + (vector-set! table VK_PAGEUP 'PAGE-UP) + (vector-set! table VK_PAGEDOWN 'PAGE-DOWN) + (vector-set! table VK_END 'END) + (vector-set! table VK_HOME 'HOME) + (vector-set! table VK_LEFT 'LEFT) + (vector-set! table VK_UP 'UP) + (vector-set! table VK_RIGHT 'RIGHT) + (vector-set! table VK_DOWN 'DOWN) + (vector-set! table VK_PRINTSCRN 'PRINT-SCREEN) + (vector-set! table VK_INSERT 'INSERT) + (vector-set! table VK_DELETE 'DELETE) + ;;(vector-set! table VK_SCRLLOCK 'SCRL-LOCK) + ;;(vector-set! table VK_NUMLOCK 'NUM-LOCK) + (vector-set! table VK_ENTER (char-code #\return)) + (vector-set! table VK_SYSRQ 'SYSRQ) + (vector-set! table VK_F1 'F1) + (vector-set! table VK_F2 'F2) + (vector-set! table VK_F3 'F3) + (vector-set! table VK_F4 'F4) + (vector-set! table VK_F5 'F5) + (vector-set! table VK_F6 'F6) + (vector-set! table VK_F7 'F7) + (vector-set! table VK_F8 'F8) + (vector-set! table VK_F9 'F9) + (vector-set! table VK_F10 'F10) + (vector-set! table VK_F11 'F11) + (vector-set! table VK_F12 'F12) + (vector-set! table VK_F13 'F13) + (vector-set! table VK_F14 'F14) + (vector-set! table VK_F15 'F15) + (vector-set! table VK_F16 'F16) + (vector-set! table VK_F17 'F17) + (vector-set! table VK_F18 'F18) + (vector-set! table VK_F19 'F19) + (vector-set! table VK_F20 'F20) + (vector-set! table VK_F21 'F21) + (vector-set! table VK_F22 'F22) + (vector-set! table VK_F23 'F23) + (vector-set! table VK_F24 'F24) + (vector-set! table VK_ENDDRAG 'END-DRAG) + (vector-set! table VK_CLEAR 'CLEAR) + (vector-set! table VK_EREOF 'EREOF) + (vector-set! table VK_PA1 'PA1) + table)) + +(define-primitives + (os2win-beep 2) + (os2win-open 1) + (os2win-close 1) + (os2win-show 2) + (os2win-write 6) + (os2win-move-cursor 3) + (os2win-shape-cursor 4) + (os2win-show-cursor 2) + (os2win-clear 5) + (os2win-scroll 7) + (os2win-invalidate 5) + (os2win-set-font 3) + (os2win-set-grid 3) + (os2win-activate 1) + (os2win-get-pos 1) + (os2win-set-pos 3) + (os2win-get-size 1) + (os2win-set-size 3) + (os2win-focus? 1) + (os2win-set-state 2) + (os2win-set-colors 3) + (os2win-get-event 1) + (os2win-event-ready? 1) + (os2win-event-descriptor 0) + (os2win-console-wid 0) + (os2win-desktop-width 0) + (os2win-desktop-height 0)) + +(define-integrable event:process-output -2) +(define-integrable event:process-status -3) +(define-integrable event:inferior-thread-output -4) + +(define-integrable (event-type event) (vector-ref event 0)) +(define-integrable (event-wid event) (vector-ref event 1)) + +(define-macro (define-event name type . slots) + `(BEGIN + (DEFINE-INTEGRABLE ,(symbol-append 'EVENT-TYPE: name) ,type) + ,@(let loop ((slots slots) (index 2)) + (if (null? slots) + '() + (cons `(DEFINE-INTEGRABLE + (,(symbol-append name '-EVENT/ (car slots)) EVENT) + (VECTOR-REF EVENT ,index)) + (loop (cdr slots) (+ index 1))))))) + +;; These must match "microcode/pros2pm.c" +(define-event button 0 number type x y flags) +(define-event close 1) +(define-event focus 2 gained?) +(define-event key 3 code flags repeat) +(define-event paint 4 xl xh yl yh) +(define-event resize 5 width height) +(define-event visibility 6 shown?) + +(define-integrable number-of-event-types 7) + +(define-integrable button-event-type:down 0) +(define-integrable button-event-type:up 1) +(define-integrable button-event-type:click 2) +(define-integrable button-event-type:double-click 3) + +;;; Constants from OS/2 header file "pmwin.h": + +(define-integrable CURSOR_SOLID #x0000) +(define-integrable CURSOR_HALFTONE #x0001) +(define-integrable CURSOR_FRAME #x0002) +(define-integrable CURSOR_FLASH #x0004) + +(define-integrable VK_BUTTON1 #x01) +(define-integrable VK_BUTTON2 #x02) +(define-integrable VK_BUTTON3 #x03) +(define-integrable VK_BREAK #x04) +(define-integrable VK_BACKSPACE #x05) +(define-integrable VK_TAB #x06) +(define-integrable VK_BACKTAB #x07) +(define-integrable VK_NEWLINE #x08) +(define-integrable VK_SHIFT #x09) +(define-integrable VK_CTRL #x0A) +(define-integrable VK_ALT #x0B) +(define-integrable VK_ALTGRAF #x0C) +(define-integrable VK_PAUSE #x0D) +(define-integrable VK_CAPSLOCK #x0E) +(define-integrable VK_ESC #x0F) +(define-integrable VK_SPACE #x10) +(define-integrable VK_PAGEUP #x11) +(define-integrable VK_PAGEDOWN #x12) +(define-integrable VK_END #x13) +(define-integrable VK_HOME #x14) +(define-integrable VK_LEFT #x15) +(define-integrable VK_UP #x16) +(define-integrable VK_RIGHT #x17) +(define-integrable VK_DOWN #x18) +(define-integrable VK_PRINTSCRN #x19) +(define-integrable VK_INSERT #x1A) +(define-integrable VK_DELETE #x1B) +(define-integrable VK_SCRLLOCK #x1C) +(define-integrable VK_NUMLOCK #x1D) +(define-integrable VK_ENTER #x1E) +(define-integrable VK_SYSRQ #x1F) +(define-integrable VK_F1 #x20) +(define-integrable VK_F2 #x21) +(define-integrable VK_F3 #x22) +(define-integrable VK_F4 #x23) +(define-integrable VK_F5 #x24) +(define-integrable VK_F6 #x25) +(define-integrable VK_F7 #x26) +(define-integrable VK_F8 #x27) +(define-integrable VK_F9 #x28) +(define-integrable VK_F10 #x29) +(define-integrable VK_F11 #x2A) +(define-integrable VK_F12 #x2B) +(define-integrable VK_F13 #x2C) +(define-integrable VK_F14 #x2D) +(define-integrable VK_F15 #x2E) +(define-integrable VK_F16 #x2F) +(define-integrable VK_F17 #x30) +(define-integrable VK_F18 #x31) +(define-integrable VK_F19 #x32) +(define-integrable VK_F20 #x33) +(define-integrable VK_F21 #x34) +(define-integrable VK_F22 #x35) +(define-integrable VK_F23 #x36) +(define-integrable VK_F24 #x37) +(define-integrable VK_ENDDRAG #x38) +(define-integrable VK_CLEAR #x39) +(define-integrable VK_EREOF #x3A) +(define-integrable VK_PA1 #x3B) +(define-integrable virtual-key-supremum #x3C) + +(define-integrable KC_NONE #x0000) +(define-integrable KC_CHAR #x0001) +(define-integrable KC_VIRTUALKEY #x0002) +(define-integrable KC_SCANCODE #x0004) +(define-integrable KC_SHIFT #x0008) +(define-integrable KC_CTRL #x0010) +(define-integrable KC_ALT #x0020) +(define-integrable KC_KEYUP #x0040) +(define-integrable KC_PREVDOWN #x0080) +(define-integrable KC_LONEKEY #x0100) +(define-integrable KC_DEADKEY #x0200) +(define-integrable KC_COMPOSITE #x0400) +(define-integrable KC_INVALIDCOMP #x0800) +(define-integrable KC_TOGGLE #x1000) +(define-integrable KC_INVALIDCHAR #x2000) + +(define-integrable window-state:top 0) +(define-integrable window-state:bottom 1) +(define-integrable window-state:show 2) +(define-integrable window-state:hide 3) +(define-integrable window-state:activate 4) +(define-integrable window-state:deactivate 5) +(define-integrable window-state:minimize 6) +(define-integrable window-state:maximize 7) +(define-integrable window-state:restore 8) \ No newline at end of file