← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/win32/dib.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/win32/dib.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
$Id: dib.scm,v 1.5 2001/12/23 17:21:00 cph Exp $
 
4
 
 
5
Copyright (c) 1993, 1999-2001 Massachusetts Institute of Technology
 
6
 
 
7
This program is free software; you can redistribute it and/or modify
 
8
it under the terms of the GNU General Public License as published by
 
9
the Free Software Foundation; either version 2 of the License, or (at
 
10
your option) any later version.
 
11
 
 
12
This program is distributed in the hope that it will be useful, but
 
13
WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
15
General Public License for more details.
 
16
 
 
17
You should have received a copy of the GNU General Public License
 
18
along with this program; if not, write to the Free Software
 
19
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
20
02111-1307, USA.
 
21
|#
 
22
 
 
23
;;;; Device-independent bitmaps (dibutils.dll)
 
24
;;; package: (win32 dib)
 
25
 
 
26
(declare (usual-integrations))
 
27
 
 
28
(define-structure (dib (constructor %make-dib))
 
29
  handle)
 
30
 
 
31
;; DIBS are handles into non-scheme memory.  They are kept on a GC
 
32
;; finalizer so that the memory can be freed if there is no longer a
 
33
;; handle to the DIB.  Because DIBS can be huge, we also support
 
34
;; explicit deallocation via DELETE-DIB.  The GC finalizer descriptor
 
35
;; is a CELL containing the handle.  It is shared with the DIB
 
36
;; structure so that explicit deallocation can signal that the dib is
 
37
;; void.
 
38
 
 
39
(define dib-finalizer)
 
40
 
 
41
(define (make-dib handle)
 
42
  (let* ((cell (make-cell handle))
 
43
         (dib (%make-dib cell)))
 
44
    (add-to-gc-finalizer! dib-finalizer dib cell)
 
45
    dib))
 
46
 
 
47
(define (dib-result handle)
 
48
  (if (= handle 0)
 
49
      #f
 
50
      (make-dib handle)))
 
51
 
 
52
(define (dib-arg dib)
 
53
  (if dib
 
54
      (cell-contents (dib-handle dib))
 
55
      0))
 
56
 
 
57
(define-windows-type dib
 
58
  (lambda (thing) (or (dib? thing) (eq? thing #f)))
 
59
  dib-arg
 
60
  dib-result)
 
61
 
 
62
(define (delete-dib dib)
 
63
  (let ((handle (cell-contents (dib-handle dib))))
 
64
    (set-cell-contents! (dib-handle dib) 0)
 
65
    (%delete-dib handle)))
 
66
 
 
67
(define dibutils.dll)
 
68
(define open-dib)
 
69
(define write-dib)
 
70
(define copy-bitmap)
 
71
(define create-dib)
 
72
(define crop-bitmap)
 
73
(define bitmap-from-dib)
 
74
(define dib-from-bitmap)
 
75
(define dib-blt)
 
76
(define %delete-dib)
 
77
(define dib-width)
 
78
(define dib-height)
 
79
(define dib-set-pixels-unaligned)
 
80
 
 
81
(define (initialize-package!)
 
82
  (set! dibutils.dll
 
83
        (find-module "DIBUTILS.DLL"))
 
84
  (set! open-dib
 
85
        (windows-procedure (open-dib (filename string))
 
86
                           dib dibutils.dll "OpenDIB"))
 
87
  (set! write-dib
 
88
        (windows-procedure (write-dib (filename string) (dib dib))
 
89
                           bool dibutils.dll "WriteDIB"))
 
90
  (set! bitmap-from-dib
 
91
        (windows-procedure (bitmap-from-dib (dib dib) (palette hpalette))
 
92
                           hbitmap dibutils.dll "BitmapFromDib"))
 
93
  (set! dib-from-bitmap
 
94
        (windows-procedure
 
95
         (dib-from-bitmap (bitmap hbitmap) (style dword) (bits word)
 
96
                          (palette hpalette))
 
97
         dib  dibutils.dll "DibFromBitmap"))
 
98
  (set! dib-blt
 
99
        (windows-procedure
 
100
         (dib-blt (dest hdc) (x int) (y int) (w int) (height int) 
 
101
                  (src dib) (src-x int) (src-y int) (raster-op long))
 
102
         bool dibutils.dll "DibBlt"))
 
103
  (set! %delete-dib
 
104
        (windows-procedure
 
105
         (%delete-dib (dib-handle handle)) bool dibutils.dll "DeleteDIB"))
 
106
  ;; int-arg is the handle, NOT dib-arg for a DIB record.
 
107
  (set! dib-height
 
108
        (windows-procedure (dib-height (dib dib)) int dibutils.dll "DibHeight"
 
109
                           expand))
 
110
  (set! dib-width
 
111
        (windows-procedure (dib-width (dib dib)) int dibutils.dll "DibWidth"
 
112
                           expand))
 
113
  (set! copy-bitmap
 
114
        (windows-procedure (copy-bitmap (bm hbitmap))
 
115
                           hbitmap dibutils.dll "CopyBitmap"))
 
116
  (set! create-dib
 
117
        (windows-procedure
 
118
         (create-dib (width int) (height int)
 
119
                     (style int) (depth int) (palette hpalette))
 
120
         dib dibutils.dll "CreateDIB"))
 
121
  (set! crop-bitmap
 
122
        (windows-procedure
 
123
         (crop-bitmap (bm hbitmap)
 
124
                      (left int) (top int) (right int) (bottom int))
 
125
         hbitmap dibutils.dll "CropBitmap"))
 
126
  (set! dib-set-pixels-unaligned
 
127
        (windows-procedure
 
128
         (dib-set-pixels-unaligned (dib dib) (pixels string))
 
129
         bool dibutils.dll "DIBSetPixelsUnaligned"))
 
130
  (set! dib-finalizer
 
131
        (make-gc-finalizer (lambda (cell) (%delete-dib (cell-contents cell)))))
 
132
  unspecific)
 
 
b'\\ No newline at end of file'