From 4ae976198f952557ddd2d234a181bf901f58ba0a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 9 Nov 2006 20:04:57 +0000
Subject: [PATCH] Implement PORT/INTERN-PROPERTY!.

---
 v7/src/runtime/port.scm    | 14 +++++++++++++-
 v7/src/runtime/runtime.pkg |  3 ++-
 2 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index f1dc09a06..602f8375c 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.45 2006/10/25 04:23:06 cph Exp $
+$Id: port.scm,v 1.46 2006/11/09 20:04:55 cph Exp $
 
 Copyright 1991,1992,1993,1994,1997,1999 Massachusetts Institute of Technology
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
@@ -637,18 +637,30 @@ USA.
 	 (operation port))))
 
 (define (port/get-property port name default)
+  (guarantee-symbol name 'PORT/GET-PROPERTY)
   (let ((p (assq name (port/properties port))))
     (if p
 	(cdr p)
 	default)))
 
 (define (port/set-property! port name value)
+  (guarantee-symbol name 'PORT/SET-PROPERTY!)
   (let ((alist (port/properties port)))
     (let ((p (assq name alist)))
       (if p
 	  (set-cdr! p value)
 	  (set-port/properties! port (cons (cons name value) alist))))))
 
+(define (port/intern-property! port name get-value)
+  (guarantee-symbol name 'PORT/INTERN-PROPERTY!)
+  (let ((alist (port/properties port)))
+    (let ((p (assq name alist)))
+      (if p
+	  (cdr p)
+	  (let ((value (get-value)))
+	    (set-port/properties! port (cons (cons name value) alist))
+	    value)))))
+
 (define (port/remove-property! port name)
   (guarantee-symbol name 'PORT/REMOVE-PROPERTY!)
   (set-port/properties! port (del-assq! name (port/properties port))))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 45a182e1f..c198d1636 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.604 2006/11/04 20:16:47 riastradh Exp $
+$Id: runtime.pkg,v 14.605 2006/11/09 20:04:57 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1961,6 +1961,7 @@ USA.
 	  port/input-blocking-mode
 	  port/input-channel
 	  port/input-terminal-mode
+	  port/intern-property!
 	  port/known-coding?
 	  port/known-codings
 	  port/known-line-ending?
-- 
2.25.1