From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Sun, 6 Nov 1994 18:06:33 +0000 (+0000)
Subject: OPERATION/OPEN now takes an mandatory argument DESCRIPTOR->DEVICE
X-Git-Tag: 20090517-FFI~7023
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4d297e212b2c6e77720ff6f48e9c93140aabe0e4;p=mit-scheme.git

OPERATION/OPEN now takes an mandatory argument DESCRIPTOR->DEVICE
which converts a descriptor into a user level GRAPHICS-DEVICE.

This allows a graphics device implementation access to the user level
GRAPHICS-DEVICE object at initialization time, which may be used in in
protection lists etc (as is done in the win32 implementation).
---

diff --git a/v7/src/runtime/graphics.scm b/v7/src/runtime/graphics.scm
index 507a43276..7937ea82e 100644
--- a/v7/src/runtime/graphics.scm
+++ b/v7/src/runtime/graphics.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: graphics.scm,v 1.12 1994/04/22 04:45:40 cph Exp $
+$Id: graphics.scm,v 1.13 1994/11/06 18:06:33 adams Exp $
 
 Copyright (c) 1989-94 Massachusetts Institute of Technology
 
@@ -231,10 +231,11 @@ MIT in each case. |#
 		type-name)
 	       (else
 		(lookup-graphics-device-type type-name)))))
-    (let ((descriptor
-	   (apply (graphics-device-type/operation/open type) arguments)))
-      (and descriptor
-	   (%make-graphics-device type descriptor)))))
+    (apply (graphics-device-type/operation/open type)
+	   (lambda (descriptor)
+	     (and descriptor
+		  (%make-graphics-device type descriptor)))
+	   arguments)))
 
 (let-syntax
     ((define-graphics-operation
diff --git a/v7/src/runtime/starbase.scm b/v7/src/runtime/starbase.scm
index 39cfe0079..7b61fdb20 100644
--- a/v7/src/runtime/starbase.scm
+++ b/v7/src/runtime/starbase.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/starbase.scm,v 1.10 1993/09/15 04:12:20 adams Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/starbase.scm,v 1.11 1994/11/06 18:06:22 adams Exp $
 
 Copyright (c) 1989-92 Massachusetts Institute of Technology
 
@@ -140,16 +140,16 @@ MIT in each case. |#
 (define (operation/available?)
   (implemented-primitive-procedure? starbase-open-device))
 
-(define (operation/open device-name driver-name)
+(define (operation/open descriptor->device device-name driver-name)
   (let ((identifier (starbase-open-device device-name driver-name)))
     (and identifier
-	 (let ((device (make-starbase-descriptor identifier)))
-	   (operation/set-coordinate-limits device -1 -1 1 1)
-	   (operation/set-text-height device 0.1)
-	   (operation/set-text-aspect device 1)
-	   (operation/set-text-slant device 0)
-	   (operation/set-text-rotation device 0)
-	   device))))
+	 (let ((descriptor (make-starbase-descriptor identifier)))
+	   (operation/set-coordinate-limits descriptor -1 -1 1 1)
+	   (operation/set-text-height descriptor 0.1)
+	   (operation/set-text-aspect descriptor 1)
+	   (operation/set-text-slant descriptor 0)
+	   (operation/set-text-rotation descriptor 0)
+	   (descriptor->device descriptor)))))
 
 (define (operation/close device)
   (starbase-close-device (starbase-device/identifier device)))