From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 15 Jan 2000 04:59:47 +0000 (+0000)
Subject: Change external representation of message flags.  Implement procedures
X-Git-Tag: 20090517-FFI~4338
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d020bf3cdf841af07ec91bda5709c0ec4f92c0da;p=mit-scheme.git

Change external representation of message flags.  Implement procedures
to map between flags and strings.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index ac51913eb..3758964c2 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.8 2000/01/14 22:40:35 cph Exp $
+;;; $Id: imail-core.scm,v 1.9 2000/01/15 04:59:47 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -396,27 +396,32 @@
   (if (not (message-flag? object))
       (error:wrong-type-argument object "message flag" procedure)))
 
+(define (string->message-flag string)
+  (let loop ((flags standard-message-flags))
+    (if (pair? flags)
+	(if (string-ci=? string (symbol-name (car flags)))
+	    (car flags)
+	    (loop (cdr flags)))
+	string)))
+
+(define (message-flag->string flag)
+  (if (symbol? flag)
+      (symbol->string flag)
+      flag))
+
 (define standard-message-flags
   '(ANSWERED DELETED EDITED FILED FORWARDED RESENT SEEN))
 
 (define (message-flags->header-field flags)
-  (make-header-field
-   message-flags:name
-   (apply string-append
-	  (map (lambda (flag)
-		 (if (symbol? flag)
-		     (string-append " :" (symbol->string flag))
-		     (string-append " " flag)))
-	       flags))))
+  (make-header-field message-flags:name
+		     (separated-append (map message-flag->string flags)
+				       " ")))
 
 (define (header-field->message-flags header)
   (and (string-ci=? message-flags:name (header-field-name header))
        ;; Extra pair needed to distinguish #F from ().
        (cons 'YUK
-	     (map (lambda (token)
-		    (if (char=? #\: (string-ref token 0))
-			(intern (string-tail token 1))
-			token))
+	     (map string->message-flag
 		  (burst-string (header-field-value header)
 				char-set:lwsp
 				#t)))))