From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 May 2000 19:11:16 +0000 (+0000)
Subject: Add PROPERTIES slot to all core objects, for use exclusively by the
X-Git-Tag: 20090517-FFI~3833
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3a922e109ce55bc766ae23f2330b24aeedc68174;p=mit-scheme.git

Add PROPERTIES slot to all core objects, for use exclusively by the
front end.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index b2f9dd188..b3143dcf0 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.66 2000/05/17 18:37:29 cph Exp $
+;;; $Id: imail-core.scm,v 1.67 2000/05/17 19:11:11 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -24,9 +24,24 @@
 
 (declare (usual-integrations))
 
+;;;; Base object type
+
+(define-class <imail-object> ()
+  (properties define accessor
+	      initializer make-1d-table))
+
+(define (get-property object key default)
+  (1d-table/get (imail-object-properties object) key default))
+
+(define (store-property! object key datum)
+  (1d-table/put! (imail-object-properties object) key datum))
+
+(define (remove-property! object key)
+  (1d-table/remove! (imail-object-properties object) key))
+
 ;;;; URL type
 
-(define-class <url> ())
+(define-class <url> (<imail-object>))
 
 ;; Return the canonical name of URL's protocol as a string.
 (define-generic url-protocol (url))
@@ -172,14 +187,12 @@
 
 ;;;; Folder type
 
-(define-class <folder> ()
+(define-class <folder> (<imail-object>)
   (url define accessor)
   (modification-count define standard
 		      initial-value 0)
   (modification-event define accessor
-		      initial-value (make-event-distributor))
-  (properties define standard
-	      initializer make-1d-table))
+		      initial-value (make-event-distributor)))
 
 (define-method write-instance ((folder <folder>) port)
   (write-instance-helper 'FOLDER folder port 
@@ -191,15 +204,6 @@
   (if (not (folder? folder))
       (error:wrong-type-argument folder "IMAIL folder" procedure)))
 
-(define (folder-get folder key default)
-  (1d-table/get (folder-properties folder) key default))
-
-(define (folder-put! folder key datum)
-  (1d-table/put! (folder-properties folder) key datum))
-
-(define (folder-remove! folder key)
-  (1d-table/remove! (folder-properties folder) key))
-
 (define-method ->url ((folder <folder>))
   (folder-url folder))
 
@@ -314,7 +318,8 @@
 
 ;;;; Message type
 
-(define-class (<message> (constructor (header-fields body flags))) ()
+(define-class (<message> (constructor (header-fields body flags)))
+    (<imail-object>)
   (header-fields define accessor)
   (body define accessor)
   (flags define standard)
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 12636f1e5..6c3e80611 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.55 2000/05/17 17:52:42 cph Exp $
+;;; $Id: imail-top.scm,v 1.56 2000/05/17 19:11:16 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -137,7 +137,7 @@ May be called with an IMAIL folder URL as argument;
    (lambda ()
      (buffer-put! buffer 'IMAIL-FOLDER folder)
      (buffer-put! buffer 'IMAIL-MESSAGE message)
-     (folder-put! folder 'BUFFER buffer)
+     (store-property! folder 'BUFFER buffer)
      (set-buffer-default-directory!
       buffer
       (if (file-folder? folder)
@@ -148,12 +148,12 @@ May be called with an IMAIL folder URL as argument;
 	 (maybe-add-command-suffix! notice-folder-modifications folder))))))
 
 (define (imail-folder->buffer folder error?)
-  (or (let ((buffer (folder-get folder 'BUFFER #f)))
+  (or (let ((buffer (get-property folder 'BUFFER #f)))
 	(and buffer
 	     (if (buffer-alive? buffer)
 		 buffer
 		 (begin
-		   (folder-remove! folder 'BUFFER)
+		   (remove-property! folder 'BUFFER)
 		   #f))))
       (and error? (error:bad-range-argument folder 'IMAIL-FOLDER->BUFFER))))