--- /dev/null
+#| -*-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"))
+\f
+(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))
+\f
+(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))))
+\f
+(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)))
+\f
+(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)))))))
+\f
+(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)))))
+\f
+(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)))
+\f
+(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)))
+\f
+(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))))
+\f
+(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))
+\f
+;;;; 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))))))))
+\f
+;;;; 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
--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+;;; 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)
+\f
+(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)
+\f
+;; 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)
+\f
+;; 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
projects / mit-scheme.git / commitdiff