From: Chris Hanson Date: Fri, 6 Jan 1995 00:50:16 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6812 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=799b4c91ba7df77a333488af2bb07c062ab442de;p=mit-scheme.git Initial revision --- diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm new file mode 100644 index 000000000..68cc93c45 --- /dev/null +++ b/v7/src/runtime/os2graph.scm @@ -0,0 +1,657 @@ +#| -*-Scheme-*- + +$Id: os2graph.scm,v 1.1 1995/01/06 00:50:16 cph Exp $ + +Copyright (c) 1995 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. |# + +;;;; OS/2 PM Graphics Interface +;;; package: (runtime os2-graphics) + +(declare (usual-integrations)) +(declare (integrate-external "graphics")) +(declare (integrate-external "os2winp")) + +(define os2-graphics-device-type) +(define event-descriptor) +(define event-previewer-registration) +(define window-list) +(define color-table) + +(define (initialize-package!) + (set! os2-graphics-device-type + (make-graphics-device-type + `((available? ,os2-graphics/available?) + (clear ,os2-graphics/clear) + (close ,os2-graphics/close) + (color? ,os2-graphics/color?) + (coordinate-limits ,os2-graphics/coordinate-limits) + (device-coordinate-limits ,os2-graphics/device-coordinate-limits) + (define-color ,os2-graphics/define-color) + (drag-cursor ,os2-graphics/drag-cursor) + (draw-line ,os2-graphics/draw-line) + (draw-lines ,os2-graphics/draw-lines) + (draw-point ,os2-graphics/draw-point) + (draw-text ,os2-graphics/draw-text) + (find-color ,os2-graphics/find-color) + (flush ,os2-graphics/flush) + (move-cursor ,os2-graphics/move-cursor) + (open ,os2-graphics/open) + (reset-clip-rectangle ,os2-graphics/reset-clip-rectangle) + (set-background-color ,os2-graphics/set-background-color) + (set-clip-rectangle ,os2-graphics/set-clip-rectangle) + (set-coordinate-limits ,os2-graphics/set-coordinate-limits) + (set-drawing-mode ,os2-graphics/set-drawing-mode) + (set-foreground-color ,os2-graphics/set-foreground-color) + (set-line-style ,os2-graphics/set-line-style)))) + (register-graphics-device-type 'OS/2 os2-graphics-device-type) + (set! event-descriptor #f) + (set! event-previewer-registration #f) + (set! window-list (make-protection-list)) + (set! color-table '()) + (for-each (lambda (entry) + (os2-graphics/define-color #f (car entry) (cdr entry))) + initial-color-definitions) + (add-event-receiver! event:before-exit finalize-pm-state!) + (add-gc-daemon! close-lost-windows-daemon)) + +(define (finalize-pm-state!) + (if event-descriptor + (begin + (do ((windows (protection-list-elements window-list) (cdr windows))) + ((null? windows)) + (close-window (car windows))) + (deregister-input-thread-event event-previewer-registration) + (set! event-previewer-registration #f) + (os2win-close-event-qid event-descriptor) + (set! event-descriptor #f) + unspecific))) + +(define (close-lost-windows-daemon) + (clean-lost-protected-objects window-list os2win-close)) + +(define (os2-graphics/available?) + (implemented-primitive-procedure? os2win-open)) + +(define (os2-graphics/open descriptor->device) + (if (not event-descriptor) + (let ((descriptor (os2win-open-event-qid))) + (set! event-previewer-registration (make-event-previewer descriptor)) + (set! event-descriptor descriptor))) + (let ((wid (os2win-open-1 event-descriptor ws_savebits "Scheme Graphics")) + (foreground-color #xFFFFFF) + (background-color #x000000)) + (os2win-set-colors wid foreground-color background-color) + (os2win-show-cursor wid #f) + (os2win-show wid #t) + (os2win-set-state wid window-state:deactivate) + (os2win-set-state wid window-state:top) + (let ((window + (let ((w.h (os2win-get-size wid))) + (make-os2-window wid + (car w.h) + (cdr w.h) + (set-normal-font! wid "4.System VIO") + foreground-color + background-color)))) + (compute-window-slopes! window) + (add-to-protection-list! window-list window wid) + (descriptor->device window)))) + +(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 (compute-window-slopes! window) + (set-os2-window/x-slope! window + (/ (- (os2-window/pel-width window) 1) + (- (os2-window/x-right window) + (os2-window/x-left window)))) + (set-os2-window/y-slope! window + (/ (- (os2-window/pel-height window) 1) + (- (os2-window/y-top window) + (os2-window/y-bottom window))))) + +(define (os2-graphics/close device) + (without-interrupts + (lambda () + (close-window (graphics-device/descriptor device))))) + +(define (close-window window) + (if (os2-window/wid window) + (begin + (os2win-close (os2-window/wid window)) + (set-os2-window/wid! window #f) + (remove-from-protection-list! window-list window)))) + +(define (make-event-previewer descriptor) + (permanently-register-input-thread-event + descriptor + (current-thread) + (lambda () + (let ((event (os2win-get-event descriptor #f))) + (if event + (process-event event)))))) + +(define (process-event event) + (let ((window + (search-protection-list window-list + (let ((wid (event-wid event))) + (lambda (window) + (eq? (os2-window/wid window) wid)))))) + (if window + (let ((handler (vector-ref event-handlers (event-type event)))) + (if handler + (handler window event)))))) + +(define event-handlers + (make-vector number-of-event-types #f)) + +(define-integrable (define-event-handler event-type handler) + (vector-set! event-handlers event-type handler)) + +(define-event-handler event-type:button + (lambda (window event) + (if (and (eq? button-event-type:down (button-event/type event)) + (not (os2win-focus? (os2-window/wid window)))) + (os2win-activate (os2-window/wid window))))) + +(define-event-handler event-type:close + (lambda (window event) + event + (close-window window))) + +(define-event-handler event-type:paint + (lambda (window event) + event + (clear-window window) + (play-segment (os2-window/segment window)))) + +(define-event-handler event-type:resize + (lambda (window event) + (set-os2-window/pel-width! window (resize-event/width event)) + (set-os2-window/pel-height! window (resize-event/height event)) + (compute-window-slopes! window))) + +(define (os2-graphics/clear device) + (reset-segment (os2-graphics-device/segment device)) + (clear-window (graphics-device/descriptor device))) + +(define (clear-window window) + (os2win-clear (os2-window/wid window) + 0 (os2-window/pel-width window) + 0 (os2-window/pel-height window))) + +(define (os2-graphics/coordinate-limits device) + (let ((window (graphics-device/descriptor device))) + (without-interrupts + (lambda () + (values (os2-window/x-left window) + (os2-window/y-bottom window) + (os2-window/x-right window) + (os2-window/y-top window)))))) + +(define (os2-graphics/device-coordinate-limits device) + (without-interrupts + (lambda () + (values 0 + 0 + (- (os2-graphics-device/pel-width device) 1) + (- (os2-graphics-device/pel-height device) 1))))) + +(define (os2-graphics/drag-cursor device x y) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (os2win-line (os2-graphics-device/wid device) + (os2-graphics-device/x->device device x) + (os2-graphics-device/y->device device y))))) + +(define (os2-graphics/draw-line device x-start y-start x-end y-end) + (os2-graphics/move-cursor device x-start y-start) + (os2-graphics/drag-cursor device x-end y-end)) + +(define (os2-graphics/draw-lines device xv yv) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (os2win-poly-line-disjoint + (os2-graphics-device/wid device) + (vector-map xv (lambda (x) (os2-graphics-device/x->device device x))) + (vector-map yv + (lambda (y) (os2-graphics-device/y->device device y))))))) + +(define (os2-graphics/draw-point device x y) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (let ((wid (os2-graphics-device/wid device)) + (x (os2-graphics-device/x->device device x)) + (y (os2-graphics-device/y->device device y)) + (type)) + (dynamic-wind + (lambda () + (set! type (map-line-style (graphics-device/line-style device))) + (os2win-set-line-type wid LINETYPE_SOLID)) + (lambda () + (os2win-move-graphics-cursor wid x y) + (os2win-line wid x y)) + (lambda () + (os2win-set-line-type wid type))))))) + +(define (os2-graphics/draw-text device x y string) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (os2win-write (os2-graphics-device/wid device) + (os2-graphics-device/x->device device x) + (fix:+ (os2-graphics-device/y->device device y) + (os2-graphics-device/char-descender device)) + string + 0 + (string-length string))))) + +(define (os2-graphics/flush device) + (flush-segment (os2-graphics-device/segment device))) + +(define (os2-graphics/move-cursor device x y) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (os2win-move-graphics-cursor (os2-graphics-device/wid device) + (os2-graphics-device/x->device device x) + (os2-graphics-device/y->device device y))))) + +(define (os2-graphics/reset-clip-rectangle device) + device + unspecific) + +(define (os2-graphics/set-clip-rectangle device x-left y-bottom x-right y-top) + device x-left y-bottom x-right y-top + unspecific) + +(define (os2-graphics/set-coordinate-limits device + x-left y-bottom x-right y-top) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (let ((window (graphics-device/descriptor device))) + (set-os2-window/x-left! window x-left) + (set-os2-window/y-bottom! window y-bottom) + (set-os2-window/x-right! window x-right) + (set-os2-window/y-top! window y-top) + (compute-window-slopes! window))))) + +(define (os2-graphics/set-drawing-mode device mode) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (os2win-set-mix (os2-graphics-device/wid device) + (map-drawing-mode mode))))) + +(define (os2-graphics/set-line-style device style) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (os2win-set-line-type (os2-graphics-device/wid device) + (map-line-style style))))) + +(define (os2-graphics/color? device) + (not (= 0 (os2win-query-capability (os2-graphics-device/wid device) + CAPS_COLOR_TABLE_SUPPORT)))) + +(define (os2-graphics/define-color device name color) + device + (if (not (and (color-name? name) + (not (char=? #\# (string-ref name 0))))) + (error:wrong-type-argument name "color name" 'DEFINE-COLOR)) + (let ((entry (lookup-color-name name)) + (color (->color color 'DEFINE-COLOR))) + (if entry + (set-cdr! entry color) + (begin + (set! color-table (cons (cons name color) color-table)) + unspecific)))) + +(define (os2-graphics/find-color device specification) + device + (->color specification 'FIND-COLOR)) + +(define (os2-graphics/set-background-color device color) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (set-os2-graphics-device/background-color! + device + (->color color 'SET-BACKGROUND-COLOR)) + (update-colors (graphics-device/descriptor device))))) + +(define (os2-graphics/set-foreground-color device color) + (drawing-operation (os2-graphics-device/segment device) + (lambda () + (set-os2-graphics-device/foreground-color! + device + (->color color 'SET-FOREGROUND-COLOR)) + (update-colors (graphics-device/descriptor device))))) + +(define (update-colors window) + (os2win-set-colors (os2-window/wid window) + (os2-window/foreground-color window) + (os2-window/background-color window))) + +(define (->color specification procedure) + (cond ((color? specification) + specification) + ((color-triple? specification) + (triple->color specification)) + ((color-name? specification) + (name->color specification procedure)) + (else + (error:wrong-type-argument specification + "color specification" + procedure)))) + +(define (color? object) + (and (exact-nonnegative-integer? object) + (< object #x1000000))) + +(define (color-triple? object) + (and (list? object) + (= 3 (length object)) + (for-all? object + (lambda (element) + (and (exact-nonnegative-integer? element) + (< element #x100)))))) + +(define (triple->color triple) + (+ (* #x10000 (car triple)) + (* #x100 (cadr triple)) + (caddr triple))) + +(define (color-name? object) + (and (string? object) + (not (string-null? object)))) + +(define (name->color name procedure) + (if (char=? #\# (string-ref name 0)) + (let ((color (substring->number name 1 (string-length name) 16))) + (if (not (color? color)) + (error:bad-range-argument name procedure)) + color) + (let ((entry (lookup-color-name name))) + (if (not entry) + (error:bad-range-argument name procedure)) + (cdr entry)))) + +(define (lookup-color-name name) + (let loop ((entries color-table)) + (and (not (null? entries)) + (if (string-ci=? (caar entries) name) + (car entries) + (loop (cdr entries)))))) + +(define initial-color-definitions + `(("red" 255 0 0) + ("green" 0 255 0) + ("blue" 0 0 255) + ("cyan" 0 255 255) + ("magenta" 255 0 255) + ("yellow" 255 255 0) + ("black" 0 0 0) + ("dark gray" 63 63 63) + ("dark grey" 63 63 63) + ("gray" 127 127 127) + ("grey" 127 127 127) + ("light gray" 191 191 191) + ("light grey" 191 191 191) + ("white" 255 255 255) + ("purple" 127 0 127) + ("dark green" 0 127 0) + ("brown" 127 63 0))) + +(define map-drawing-mode + (let ((modes + (vector FM_ZERO + FM_AND + FM_MASKSRCNOT + FM_OVERPAINT + FM_SUBTRACT + FM_LEAVEALONE + FM_XOR + FM_OR + FM_NOTMERGESRC + FM_NOTXORSRC + FM_INVERT + FM_MERGESRCNOT + FM_NOTCOPYSRC + FM_MERGENOTSRC + FM_NOTMASKSRC + FM_ONE))) + (lambda (mode) + (if (not (and (fix:fixnum? mode) (fix:<= 0 mode) (fix:< mode 16))) + (error:wrong-type-argument mode "graphics line style" + 'MAP-DRAWING-MODE)) + (vector-ref modes mode)))) + +(define map-line-style + (let ((styles + (vector LINETYPE_SOLID + LINETYPE_SHORTDASH + LINETYPE_DOT + LINETYPE_DASHDOT + LINETYPE_DASHDOUBLEDOT + LINETYPE_LONGDASH + LINETYPE_DOUBLEDOT + LINETYPE_ALTERNATE))) + (lambda (style) + (if (not (and (fix:fixnum? style) (fix:<= 0 style) (fix:< style 8))) + (error:wrong-type-argument style "graphics line style" + 'MAP-LINE-STYLE)) + (vector-ref styles style)))) + +(define-structure (os2-window + (conc-name os2-window/) + (constructor make-os2-window + (wid + pel-width + pel-height + font-metrics + foreground-color + background-color))) + wid + pel-width + pel-height + font-metrics + foreground-color + background-color + (x-left -1) + (y-bottom -1) + (x-right 1) + (y-top 1) + x-slope + y-slope + (segment (make-segment) read-only #t)) + +(define-integrable (os2-graphics-device/wid device) + (os2-window/wid (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/pel-width device) + (os2-window/pel-width (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/pel-height device) + (os2-window/pel-height (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/char-descender device) + (font-metrics/descender + (os2-window/font-metrics (graphics-device/descriptor device)))) + +(define-integrable (os2-graphics-device/x-left device) + (os2-window/x-left (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/y-bottom device) + (os2-window/y-bottom (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/x-right device) + (os2-window/x-right (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/y-top device) + (os2-window/y-top (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/x-slope device) + (os2-window/x-slope (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/y-slope device) + (os2-window/y-slope (graphics-device/descriptor device))) + +(define-integrable (os2-graphics-device/segment device) + (os2-window/segment (graphics-device/descriptor device))) + +(define (os2-graphics-device/x->device device x) + (round->exact (* (os2-graphics-device/x-slope device) + (- x (os2-graphics-device/x-left device))))) + +(define (os2-graphics-device/y->device device y) + (round->exact (* (os2-graphics-device/y-slope device) + (- y (os2-graphics-device/y-bottom device))))) + +(define-integrable (os2-graphics-device/foreground-color device) + (os2-window/foreground-color (graphics-device/descriptor device))) + +(define-integrable (set-os2-graphics-device/foreground-color! device color) + (set-os2-window/foreground-color! (graphics-device/descriptor device) color)) + +(define-integrable (os2-graphics-device/background-color device) + (os2-window/background-color (graphics-device/descriptor device))) + +(define-integrable (set-os2-graphics-device/background-color! device color) + (set-os2-window/background-color! (graphics-device/descriptor device) color)) + +;;;; Protection lists + +(define (make-protection-list) + (list 'PROTECTION-LIST)) + +;; This is used after a disk-restore, to remove invalid information. + +(define (drop-all-protected-objects list) + (with-absolutely-no-interrupts + (lambda () + (set-cdr! list '())))) + +(define (add-to-protection-list! list scheme-object microcode-object) + (with-absolutely-no-interrupts + (lambda () + (set-cdr! list + (cons (weak-cons scheme-object microcode-object) + (cdr list)))))) + +(define (remove-from-protection-list! list scheme-object) + (with-absolutely-no-interrupts + (lambda () + (let loop ((associations (cdr list)) (previous list)) + (if (not (null? associations)) + (if (eq? scheme-object (weak-pair/car? (car associations))) + (set-cdr! previous (cdr associations)) + (loop (cdr associations) associations))))))) + +(define (clean-lost-protected-objects list cleaner) + (let loop ((associations (cdr list)) (previous list)) + (if (not (null? associations)) + (if (weak-pair/car? (car associations)) + (loop (cdr associations) associations) + (begin + (cleaner (weak-cdr (car associations))) + (let ((next (cdr associations))) + (set-cdr! previous next) + (loop next previous))))))) + +(define (search-protection-list list predicate) + (let loop ((associations (cdr list))) + (and (not (null? associations)) + (let ((scheme-object (weak-car (car associations)))) + (if (and scheme-object (predicate scheme-object)) + scheme-object + (loop (cdr associations))))))) + +(define (protection-list-elements list) + (with-absolutely-no-interrupts + (lambda () + (let loop ((associations (cdr list))) + (cond ((null? associations) + '()) + ((weak-pair/car? (car associations)) + (cons (weak-car (car associations)) + (loop (cdr associations)))) + (else + (loop (cdr associations)))))))) + +;;;; Drawing Segments + +(define (make-segment) + (cons (cons '() '()) + (cons '() '()))) + +(define (reset-segment segment) + (without-interrupts + (lambda () + (set-car! (car segment) '()) + (set-cdr! (car segment) '()) + (set-car! (cdr segment) '()) + (set-cdr! (cdr segment) '())))) + +(define (flush-segment segment) + (%play-segment + (without-interrupts + (lambda () + (let ((new-head (caar segment)) + (new-tail (cdar segment))) + (%enqueue-segment (cdr segment) new-head new-tail) + (set-car! (car segment) '()) + (set-cdr! (car segment) '()) + new-head))))) + +(define (drawing-operation segment thunk) + (without-interrupts + (lambda () + (let ((new (list thunk))) + (%enqueue-segment (car segment) new new))))) + +(define (play-segment segment) + (%play-segment (cadr segment))) + +(define (%enqueue-segment h.t new-head new-tail) + (let ((old (cdr h.t))) + (set-cdr! h.t new-tail) + (if (null? old) + (set-car! h.t new-head) + (set-cdr! old new-head)))) + +(define (%play-segment thunks) + (do ((thunks thunks (cdr thunks))) + ((null? thunks)) + ((car thunks)))) \ No newline at end of file diff --git a/v7/src/runtime/os2winp.scm b/v7/src/runtime/os2winp.scm new file mode 100644 index 000000000..16ef6a493 --- /dev/null +++ b/v7/src/runtime/os2winp.scm @@ -0,0 +1,360 @@ +#| -*-Scheme-*- + +$Id: os2winp.scm,v 1.1 1995/01/06 00:50:03 cph Exp $ + +Copyright (c) 1995 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. |# + +;;;; OS/2 PM Interface -- Primitives +;;; package: (runtime os2-window) + +(declare (usual-integrations)) + +(define-primitives + (os2win-beep 2) + (os2win-open 2) + (os2win-open-1 3) + (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-move-graphics-cursor 3) + (os2win-line 3) + (os2win-poly-line 3) + (os2win-poly-line-disjoint 3) + (os2win-set-line-type 2) + (os2win-query-capabilities 3) + (os2win-query-capability 2) + (os2win-set-title 2) + (os2win-open-event-qid 0) + (os2win-close-event-qid 1) + (os2win-get-event 2) + (os2win-event-ready? 2) + (os2win-console-wid 0) + (os2win-desktop-width 0) + (os2win-desktop-height 0)) + +(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) + +(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)) + +;;; 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 LINETYPE_DEFAULT 0) +(define-integrable LINETYPE_DOT 1) +(define-integrable LINETYPE_SHORTDASH 2) +(define-integrable LINETYPE_DASHDOT 3) +(define-integrable LINETYPE_DOUBLEDOT 4) +(define-integrable LINETYPE_LONGDASH 5) +(define-integrable LINETYPE_DASHDOUBLEDOT 6) +(define-integrable LINETYPE_SOLID 7) +(define-integrable LINETYPE_INVISIBLE 8) +(define-integrable LINETYPE_ALTERNATE 9) + +(define-integrable FM_DEFAULT 0) +(define-integrable FM_OR 1) +(define-integrable FM_OVERPAINT 2) +(define-integrable FM_XOR 4) +(define-integrable FM_LEAVEALONE 5) +(define-integrable FM_AND 6) +(define-integrable FM_SUBTRACT 7) +(define-integrable FM_MASKSRCNOT 8) +(define-integrable FM_ZERO 9) +(define-integrable FM_NOTMERGESRC 10) +(define-integrable FM_NOTXORSRC 11) +(define-integrable FM_INVERT 12) +(define-integrable FM_MERGESRCNOT 13) +(define-integrable FM_NOTCOPYSRC 14) +(define-integrable FM_MERGENOTSRC 15) +(define-integrable FM_NOTMASKSRC 16) +(define-integrable FM_ONE 17) + +(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) + +(define-integrable WS_VISIBLE #x80000000) +(define-integrable WS_DISABLED #x40000000) +(define-integrable WS_CLIPCHILDREN #x20000000) +(define-integrable WS_CLIPSIBLINGS #x10000000) +(define-integrable WS_PARENTCLIP #x08000000) +(define-integrable WS_SAVEBITS #x04000000) +(define-integrable WS_SYNCPAINT #x02000000) +(define-integrable WS_MINIMIZED #x01000000) +(define-integrable WS_MAXIMIZED #x00800000) +(define-integrable WS_ANIMATE #x00400000) + +;; codes for OS2WIN-QUERY-CAPABILITIES and OS2WIN-QUERY-CAPABILITY +(define-integrable CAPS_FAMILY 0) +(define-integrable CAPS_IO_CAPS 1) +(define-integrable CAPS_TECHNOLOGY 2) +(define-integrable CAPS_DRIVER_VERSION 3) +(define-integrable CAPS_WIDTH 4) ;pels +(define-integrable CAPS_HEIGHT 5) ;pels +(define-integrable CAPS_WIDTH_IN_CHARS 6) +(define-integrable CAPS_HEIGHT_IN_CHARS 7) +(define-integrable CAPS_HORIZONTAL_RESOLUTION 8) ;pels per meter +(define-integrable CAPS_VERTICAL_RESOLUTION 9) ;pels per meter +(define-integrable CAPS_CHAR_WIDTH 10) ;pels +(define-integrable CAPS_CHAR_HEIGHT 11) ;pels +(define-integrable CAPS_SMALL_CHAR_WIDTH 12) ;pels +(define-integrable CAPS_SMALL_CHAR_HEIGHT 13) ;pels +(define-integrable CAPS_COLORS 14) +(define-integrable CAPS_COLOR_PLANES 15) +(define-integrable CAPS_COLOR_BITCOUNT 16) +(define-integrable CAPS_COLOR_TABLE_SUPPORT 17) +(define-integrable CAPS_MOUSE_BUTTONS 18) +(define-integrable CAPS_FOREGROUND_MIX_SUPPORT 19) +(define-integrable CAPS_BACKGROUND_MIX_SUPPORT 20) +(define-integrable CAPS_VIO_LOADABLE_FONTS 21) +(define-integrable CAPS_WINDOW_BYTE_ALIGNMENT 22) +(define-integrable CAPS_BITMAP_FORMATS 23) +(define-integrable CAPS_RASTER_CAPS 24) +(define-integrable CAPS_MARKER_HEIGHT 25) ;pels +(define-integrable CAPS_MARKER_WIDTH 26) ;pels +(define-integrable CAPS_DEVICE_FONTS 27) +(define-integrable CAPS_GRAPHICS_SUBSET 28) +(define-integrable CAPS_GRAPHICS_VERSION 29) +(define-integrable CAPS_GRAPHICS_VECTOR_SUBSET 30) +(define-integrable CAPS_DEVICE_WINDOWING 31) +(define-integrable CAPS_ADDITIONAL_GRAPHICS 32) +(define-integrable CAPS_PHYS_COLORS 33) +(define-integrable CAPS_COLOR_INDEX 34) +(define-integrable CAPS_GRAPHICS_CHAR_WIDTH 35) +(define-integrable CAPS_GRAPHICS_CHAR_HEIGHT 36) +(define-integrable CAPS_HORIZONTAL_FONT_RES 37) +(define-integrable CAPS_VERTICAL_FONT_RES 38) +(define-integrable CAPS_DEVICE_FONT_SIM 39) +(define-integrable CAPS_LINEWIDTH_THICK 40) +(define-integrable CAPS_DEVICE_POLYSET_POINTS 41) + +;; Constants for CAPS_IO_CAPS +(define-integrable CAPS_IO_DUMMY 1) +(define-integrable CAPS_IO_SUPPORTS_OP 2) +(define-integrable CAPS_IO_SUPPORTS_IP 3) +(define-integrable CAPS_IO_SUPPORTS_IO 4) + +;; Constants for CAPS_TECHNOLOGY +(define-integrable CAPS_TECH_UNKNOWN 0) +(define-integrable CAPS_TECH_VECTOR_PLOTTER 1) +(define-integrable CAPS_TECH_RASTER_DISPLAY 2) +(define-integrable CAPS_TECH_RASTER_PRINTER 3) +(define-integrable CAPS_TECH_RASTER_CAMERA 4) +(define-integrable CAPS_TECH_POSTSCRIPT 5) + +;; Constants for CAPS_COLOR_TABLE_SUPPORT +(define-integrable CAPS_COLTABL_RGB_8 #x0001) +(define-integrable CAPS_COLTABL_RGB_8_PLUS #x0002) +(define-integrable CAPS_COLTABL_TRUE_MIX #x0004) +(define-integrable CAPS_COLTABL_REALIZE #x0008) + +;; Constants for CAPS_FOREGROUND_MIX_SUPPORT +(define-integrable CAPS_FM_OR #x0001) +(define-integrable CAPS_FM_OVERPAINT #x0002) +(define-integrable CAPS_FM_XOR #x0008) +(define-integrable CAPS_FM_LEAVEALONE #x0010) +(define-integrable CAPS_FM_AND #x0020) +(define-integrable CAPS_FM_GENERAL_BOOLEAN #x0040) + +;; Constants for CAPS_BACKGROUND_MIX_SUPPORT +(define-integrable CAPS_BM_OR #x0001) +(define-integrable CAPS_BM_OVERPAINT #x0002) +(define-integrable CAPS_BM_XOR #x0008) +(define-integrable CAPS_BM_LEAVEALONE #x0010) +(define-integrable CAPS_BM_AND #x0020) +(define-integrable CAPS_BM_GENERAL_BOOLEAN #x0040) +(define-integrable CAPS_BM_SRCTRANSPARENT #x0080) +(define-integrable CAPS_BM_DESTTRANSPARENT #x0100) + +;; Constants for CAPS_DEVICE_WINDOWING +(define-integrable CAPS_DEV_WINDOWING_SUPPORT 1) + +;; Constants for CAPS_ADDITIONAL_GRAPHICS +(define-integrable CAPS_VDD_DDB_TRANSFER #x0001) +(define-integrable CAPS_GRAPHICS_KERNING_SUPPORT #x0002) +(define-integrable CAPS_FONT_OUTLINE_DEFAULT #x0004) +(define-integrable CAPS_FONT_IMAGE_DEFAULT #x0008) +;; bits represented by values #x0010 and #x0020 are reserved +(define-integrable CAPS_SCALED_DEFAULT_MARKERS #x0040) +(define-integrable CAPS_COLOR_CURSOR_SUPPORT #x0080) +(define-integrable CAPS_PALETTE_MANAGER #x0100) +(define-integrable CAPS_COSMETIC_WIDELINE_SUPPORT #x0200) +(define-integrable CAPS_DIRECT_FILL #x0400) +(define-integrable CAPS_REBUILD_FILLS #x0800) +(define-integrable CAPS_CLIP_FILLS #x1000) +(define-integrable CAPS_ENHANCED_FONTMETRICS #x2000) +(define-integrable CAPS_TRANSFORM_SUPPORT #x4000) + +;; Constants for CAPS_WINDOW_BYTE_ALIGNMENT +(define-integrable CAPS_BYTE_ALIGN_REQUIRED 0) +(define-integrable CAPS_BYTE_ALIGN_RECOMMENDED 1) +(define-integrable CAPS_BYTE_ALIGN_NOT_REQUIRED 2) + +;; Constants for CAPS_RASTER_CAPS +(define-integrable CAPS_RASTER_BITBLT #x0001) +(define-integrable CAPS_RASTER_BANDING #x0002) +(define-integrable CAPS_RASTER_BITBLT_SCALING #x0004) +(define-integrable CAPS_RASTER_SET_PEL #x0010) +(define-integrable CAPS_RASTER_FONTS #x0020) +(define-integrable CAPS_RASTER_FLOOD_FILL #x0040) \ No newline at end of file