Implement PORT/INTERN-PROPERTY!.

diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index f1dc09a06ad323b0e1a2e47df462a5bbe021a926..602f8375c3903a4166c0adc6b524259e206d8a5a 100644 (file)
--- 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))))
 \f
 (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 45a182e1f52f78bd3f0d788b64535b78a425d9d4..c198d16368a4ed3082f075a92fe310f61be1014b 100644 (file)
--- 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?