From 1f176d3633421c71b5f87204aa9ee59eaa28b11e Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 13 Apr 2000 03:13:46 +0000 Subject: [PATCH] Eliminate reference to now-obsolete protection lists. --- v7/src/win32/dib.scm | 177 +++++++++++++++++------------------------ v7/src/win32/win32.pkg | 11 +-- 2 files changed, 78 insertions(+), 110 deletions(-) diff --git a/v7/src/win32/dib.scm b/v7/src/win32/dib.scm index e0bc71ae8..ab1f681c9 100644 --- a/v7/src/win32/dib.scm +++ b/v7/src/win32/dib.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dib.scm,v 1.3 1999/01/02 06:19:10 cph Exp $ +$Id: dib.scm,v 1.4 2000/04/13 03:12:09 cph Exp $ -Copyright (c) 1993, 1999 Massachusetts Institute of Technology +Copyright (c) 1993, 1999, 2000 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,60 +19,48 @@ along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |# -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Device-independent bitmaps (dibutils.dll) ;;; package: (win32 dib) + +(define-structure (dib (constructor %make-dib)) + handle) -(define-structure - (dib - (constructor %make-dib)) - handle -) +;; DIBS are handles into non-scheme memory. They are kept on a GC +;; finalizer so that the memory can be freed if there is no longer a +;; handle to the DIB. Because DIBS can be huge, we also support +;; explicit deallocation via DELETE-DIB. The GC finalizer descriptor +;; is a CELL containing the handle. It is shared with the DIB +;; structure so that explicit deallocation can signal that the dib is +;; void. -;; DIBS are handles into non-scheme memory. They are kept on a protection list -;; so that the memory can be freed if there is no longer a handle to the DIB. -;; Because DIBS can be huge, we also support explicit deallocation via DELETE-DIB. -;; The protection list descriptor is a CELL containing the handle. It is shared with -;; the DIB structure so that explicit deallocation can signal that the dib is void. - -(define dib-protection-list) +(define dib-finalizer) (define (make-dib handle) (let* ((cell (make-cell handle)) - (dib (%make-dib cell))) - (add-to-protection-list! dib-protection-list dib cell) + (dib (%make-dib cell))) + (add-to-gc-finalizer! dib-finalizer dib cell) dib)) +(define (dib-result handle) + (if (= handle 0) + #f + (make-dib handle))) -(define dib-result - (lambda (handle) - (if (= handle 0) - #f - (make-dib handle)))) - -(define dib-arg - (lambda (dib) - (if dib - (cell-contents (dib-handle dib)) - 0))) +(define (dib-arg dib) + (if dib + (cell-contents (dib-handle dib)) + 0)) (define-windows-type dib (lambda (thing) (or (dib? thing) (eq? thing #f))) dib-arg dib-result) - (define (delete-dib dib) (let ((handle (cell-contents (dib-handle dib)))) (set-cell-contents! (dib-handle dib) 0) (%delete-dib handle))) - -(define (destroy-lost-dibs) - (clean-lost-protected-objects - dib-protection-list - (lambda (cell) (%delete-dib (cell-contents cell))))) - - + (define dibutils.dll) (define open-dib) (define write-dib) @@ -88,69 +76,54 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define dib-set-pixels-unaligned) (define (initialize-package!) - - (set! dibutils.dll (find-module "DIBUTILS.DLL")) - - (set! open-dib - (windows-procedure (open-dib (filename string)) - dib dibutils.dll "OpenDIB")) - - (set! write-dib - (windows-procedure (write-dib (filename string) (dib dib)) - bool dibutils.dll "WriteDIB")) - - - (set! bitmap-from-dib - (windows-procedure (bitmap-from-dib (dib dib) (palette hpalette)) - hbitmap dibutils.dll "BitmapFromDib")) - - (set! dib-from-bitmap - (windows-procedure - (dib-from-bitmap (bitmap hbitmap) (style dword) (bits word) (palette hpalette)) - dib dibutils.dll "DibFromBitmap")) - - (set! dib-blt - (windows-procedure - (dib-blt (dest hdc) (x int) (y int) (w int) (height int) - (src dib) (src-x int) (src-y int) (raster-op long)) - bool dibutils.dll "DibBlt")) - - (set! %delete-dib - (windows-procedure - (%delete-dib (dib-handle handle)) bool dibutils.dll "DeleteDIB")) - ;; int-arg is the handle, NOT dib-arg for a DIB record. - - (set! dib-height - (windows-procedure (dib-height (dib dib)) int dibutils.dll "DibHeight" expand)) - - (set! dib-width - (windows-procedure (dib-width (dib dib)) int dibutils.dll "DibWidth" expand)) - - (set! copy-bitmap - (windows-procedure (copy-bitmap (bm hbitmap)) - hbitmap dibutils.dll "CopyBitmap")) - - (set! create-dib - (windows-procedure - (create-dib (width int) (height int) - (style int) (depth int) (palette hpalette)) - dib dibutils.dll "CreateDIB")) - - (set! crop-bitmap - (windows-procedure - (crop-bitmap (bm hbitmap) (left int) (top int) (right int) (bottom int)) - hbitmap dibutils.dll "CropBitmap")) - - (set! dib-set-pixels-unaligned - (windows-procedure - (dib-set-pixels-unaligned (dib dib) (pixels string)) - bool dibutils.dll "DIBSetPixelsUnaligned")) - - (set! dib-protection-list (make-protection-list)) - (add-gc-daemon! destroy-lost-dibs) -) - - - - - + (set! dibutils.dll + (find-module "DIBUTILS.DLL")) + (set! open-dib + (windows-procedure (open-dib (filename string)) + dib dibutils.dll "OpenDIB")) + (set! write-dib + (windows-procedure (write-dib (filename string) (dib dib)) + bool dibutils.dll "WriteDIB")) + (set! bitmap-from-dib + (windows-procedure (bitmap-from-dib (dib dib) (palette hpalette)) + hbitmap dibutils.dll "BitmapFromDib")) + (set! dib-from-bitmap + (windows-procedure + (dib-from-bitmap (bitmap hbitmap) (style dword) (bits word) + (palette hpalette)) + dib dibutils.dll "DibFromBitmap")) + (set! dib-blt + (windows-procedure + (dib-blt (dest hdc) (x int) (y int) (w int) (height int) + (src dib) (src-x int) (src-y int) (raster-op long)) + bool dibutils.dll "DibBlt")) + (set! %delete-dib + (windows-procedure + (%delete-dib (dib-handle handle)) bool dibutils.dll "DeleteDIB")) + ;; int-arg is the handle, NOT dib-arg for a DIB record. + (set! dib-height + (windows-procedure (dib-height (dib dib)) int dibutils.dll "DibHeight" + expand)) + (set! dib-width + (windows-procedure (dib-width (dib dib)) int dibutils.dll "DibWidth" + expand)) + (set! copy-bitmap + (windows-procedure (copy-bitmap (bm hbitmap)) + hbitmap dibutils.dll "CopyBitmap")) + (set! create-dib + (windows-procedure + (create-dib (width int) (height int) + (style int) (depth int) (palette hpalette)) + dib dibutils.dll "CreateDIB")) + (set! crop-bitmap + (windows-procedure + (crop-bitmap (bm hbitmap) + (left int) (top int) (right int) (bottom int)) + hbitmap dibutils.dll "CropBitmap")) + (set! dib-set-pixels-unaligned + (windows-procedure + (dib-set-pixels-unaligned (dib dib) (pixels string)) + bool dibutils.dll "DIBSetPixelsUnaligned")) + (set! dib-finalizer + (make-gc-finalizer (lambda (cell) (%delete-dib (cell-contents cell))))) + unspecific) \ No newline at end of file diff --git a/v7/src/win32/win32.pkg b/v7/src/win32/win32.pkg index dfc6e2833..a73ee7fc2 100644 --- a/v7/src/win32/win32.pkg +++ b/v7/src/win32/win32.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: win32.pkg,v 1.11 1999/01/02 06:19:10 cph Exp $ +$Id: win32.pkg,v 1.12 2000/04/13 03:13:46 cph Exp $ -Copyright (c) 1993-1999 Massachusetts Institute of Technology +Copyright (c) 1993-2000 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -82,9 +82,4 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define-package (win32 dib) (files "dib") - (parent (win32)) - (import (runtime primitive-io) - make-protection-list - add-to-protection-list! - clean-lost-protected-objects) -) + (parent (win32))) \ No newline at end of file -- 2.25.1