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 b2f9dd188ec09889eb69cf32ea66a0091d4541d5..b3143dcf06362d6a1649804bcc093c58998cd7ec 100644 (file)
--- 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))
 \f
+;;;; 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))
+\f
 ;;;; 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 @@
 \f
 ;;;; 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 @@
 \f
 ;;;; 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 12636f1e5019c2164c05e4bff7a5341d04b75809..6c3e806110eed83e708bb11a352e29eab0be7f74 100644 (file)
--- 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))))