DECORATED-STRING-APPEND.
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-core.scm,v 1.27 2000/04/07 20:58:49 cph Exp $
+;;; $Id: imail-core.scm,v 1.28 2000/04/14 01:45:34 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
'("answered" "deleted" "edited" "filed" "forwarded" "resent" "seen"))
(define (message-flags->header-field flags)
- (make-header-field message-flags:name (separated-append flags " ")))
+ (make-header-field message-flags:name
+ (decorated-string-append "" " " "" flags)))
(define (header-field->message-flags header)
(and (string-ci=? message-flags:name (header-field-name header))
(define (get-all-header-field-values headers name)
(let ((headers (get-all-header-fields headers name)))
(and (pair? headers)
- (separated-append (map (lambda (header)
- (string-trim (header-field-value header)))
- headers)
- ", "))))
+ (decorated-string-append
+ "" ", " ""
+ (map (lambda (header)
+ (string-trim (header-field-value header)))
+ headers)))))
\f
(define (header-field-name? object)
(and (string? object)
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-rmail.scm,v 1.17 2000/04/07 19:39:10 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.18 2000/04/14 01:45:37 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define (compute-rmail-folder-header-fields folder)
(list (make-header-field "Version" " 5")
(make-header-field "Labels"
- (separated-append
- (flags->rmail-labels (folder-flags folder))
- ","))
+ (decorated-string-append
+ "" "," ""
+ (flags->rmail-labels (folder-flags folder))))
(make-header-field "Note" " This is the header of an rmail file.")
(make-header-field "Note" " If you are seeing it in rmail,")
(make-header-field "Note"
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-top.scm,v 1.19 2000/04/07 20:59:26 cph Exp $
+;;; $Id: imail-top.scm,v 1.20 2000/04/14 01:45:39 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(string-append "message with flag"
(if (fix:= 1 (length flags)) "" "s")
" "
- (separated-append flags ", "))))))
+ (decorated-string-append "" ", " ""
+ flags))))))
(define-command imail-previous-flagged-message
"Show previous message with one of the flags FLAGS.
"/"
(number->string (folder-length folder)))))
(if (pair? flags)
- (string-append line "," (separated-append flags ","))
+ (string-append line ","
+ (decorated-string-append "" "," "" flags))
line))
" 0/0")))))
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-util.scm,v 1.9 2000/04/13 20:14:25 cph Exp $
+;;; $Id: imail-util.scm,v 1.10 2000/04/14 01:45:43 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
lines)))
(define (lines->string lines)
- (suffixed-append lines "\n"))
+ (decorated-string-append "" "" "\n" lines))
(define (short-name->pathname name)
(merge-pathnames name (current-home-directory)))
(write-char #\: port)
(write-string value port)
(newline port))
-\f
-(define (separated-append tokens separator)
- (cond ((not (pair? tokens)) "")
- ((not (pair? (cdr tokens))) (car tokens))
- (else
- (let ((string
- (make-string
- (let ((ns (string-length separator)))
- (do ((tokens (cdr tokens) (cdr tokens))
- (count (string-length (car tokens))
- (fix:+ count
- (fix:+ (string-length (car tokens))
- ns))))
- ((not (pair? tokens)) count))))))
- (let loop
- ((tokens (cdr tokens))
- (index (string-move! (car tokens) string 0)))
- (if (pair? tokens)
- (loop (cdr tokens)
- (string-move! (car tokens)
- string
- (string-move! separator string index)))))
- string))))
-
-(define (suffixed-append tokens suffix)
- (if (pair? tokens)
- (let ((string
- (make-string
- (let ((ns (string-length suffix)))
- (do ((tokens tokens (cdr tokens))
- (count 0
- (fix:+ count
- (fix:+ (string-length (car tokens)) ns))))
- ((not (pair? tokens)) count))))))
- (let loop ((tokens tokens) (index 0))
- (if (pair? tokens)
- (loop (cdr tokens)
- (string-move! suffix
- string
- (string-move! (car tokens) string index)))))
- string)
- ""))
-
-(define (prefixed-append tokens prefix)
- (if (pair? tokens)
- (let ((string
- (make-string
- (let ((ns (string-length prefix)))
- (do ((tokens tokens (cdr tokens))
- (count 0
- (fix:+ count
- (fix:+ (string-length (car tokens)) ns))))
- ((not (pair? tokens)) count))))))
- (let loop ((tokens tokens) (index 0))
- (if (pair? tokens)
- (loop (cdr tokens)
- (string-move! (car tokens)
- string
- (string-move! prefix string index)))))
- string)
- ""))
-\f
+
(define (read-lines port)
(source->list (lambda () (read-line port))))
;;; -*-Scheme-*-
;;;
-;;; $Id: rexp.scm,v 1.12 2000/04/13 20:23:29 cph Exp $
+;;; $Id: rexp.scm,v 1.13 2000/04/14 01:45:45 cph Exp $
;;;
;;; Copyright (c) 2000 Massachusetts Institute of Technology
;;;
(cdr entry)
(lose))))))
(case (car rexp)
- ((ALTERNATIVES) (separated-append (rexp-args) "\\|"))
+ ((ALTERNATIVES)
+ (decorated-string-append "" "\\|" "" (rexp-args)))
((SEQUENCE) (apply string-append (rexp-args)))
((GROUP) (string-append "\\(" (rexp-arg) "\\)"))
((OPTIONAL) (string-append (rexp-arg) "?"))
((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
(else (lose))))))
(else (lose)))))
-\f
+
(define (case-fold-string s)
(let ((end (string-length s)))
(let loop ((start 0) (parts '()))
(re-quote-string
(substring s start index))
parts))
- (apply string-append (reverse! parts)))))))
-
-(define (separated-append tokens separator)
- (cond ((not (pair? tokens)) "")
- ((not (pair? (cdr tokens))) (car tokens))
- (else
- (let ((string
- (make-string
- (let ((ns (string-length separator)))
- (do ((tokens (cdr tokens) (cdr tokens))
- (count (string-length (car tokens))
- (fix:+ count
- (fix:+ (string-length (car tokens))
- ns))))
- ((not (pair? tokens)) count))))))
- (let loop
- ((tokens (cdr tokens))
- (index (string-move! (car tokens) string 0)))
- (if (pair? tokens)
- (loop (cdr tokens)
- (string-move! (car tokens)
- string
- (string-move! separator string index)))))
- string))))
\ No newline at end of file
+ (apply string-append (reverse! parts)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: rfc822.scm,v 1.3 2000/01/14 18:09:20 cph Exp $
+;;; $Id: rfc822.scm,v 1.4 2000/04/14 01:45:47 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define (rfc822-addresses->string addresses)
(if (null? addresses)
""
- (separated-append addresses ", ")))
+ (decorated-string-append "" ", " "" addresses)))
(define (string->rfc822-addresses string)
(let ((address-list
(eqv? #\@ (cadr local-part))
(let ((domain (parse-domain (cddr local-part))))
(and domain
- (cons (string-append (separated-append (car local-part) ".")
- "@"
- (separated-append (car domain) "."))
+ (cons (string-append
+ (decorated-string-append "" "." ""
+ (car local-part))
+ "@"
+ (decorated-string-append "" "." ""
+ (car domain)))
(cdr domain)))))))
(define (parse-domain tokens)
;;; -*-Scheme-*-
;;;
-;;; $Id: url.scm,v 1.6 2000/04/13 16:58:40 cph Exp $
+;;; $Id: url.scm,v 1.7 2000/04/14 01:45:49 cph Exp $
;;;
;;; Copyright (c) 2000 Massachusetts Institute of Technology
;;;
url:char-set:escaped)))
(if index
(begin
- (substring-move-left! string start index encoded i)
+ (substring-move! string start index encoded i)
(let ((i (fix:+ i (fix:- index start)))
(code (vector-8b-ref string index)))
(string-set! encoded i #\%)
(fix:+ i 2)
(string-ref digits (fix:and code #x0F)))
(loop (fix:+ index 1) (fix:+ i 3))))
- (substring-move-left! string start end
- encoded i))))
+ (substring-move! string start end encoded i))))
encoded))))
(define (url:decode-substring string start end)
(let ((regs (re-substring-search-forward patt string start end)))
(if regs
(let ((index (re-match-start-index 0 regs)))
- (substring-move-left! string start index decoded i)
+ (substring-move! string start index decoded i)
(let ((i (fix:+ i (fix:- index start))))
(vector-8b-set!
decoded i
(fix:+ index 3)
16))
(loop (fix:+ index 3) (fix:+ i 1))))
- (substring-move-left! string start end decoded i))))
+ (substring-move! string start end decoded i))))
decoded)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: rexp.scm,v 1.12 2000/04/13 20:23:29 cph Exp $
+;;; $Id: rexp.scm,v 1.13 2000/04/14 01:45:45 cph Exp $
;;;
;;; Copyright (c) 2000 Massachusetts Institute of Technology
;;;
(cdr entry)
(lose))))))
(case (car rexp)
- ((ALTERNATIVES) (separated-append (rexp-args) "\\|"))
+ ((ALTERNATIVES)
+ (decorated-string-append "" "\\|" "" (rexp-args)))
((SEQUENCE) (apply string-append (rexp-args)))
((GROUP) (string-append "\\(" (rexp-arg) "\\)"))
((OPTIONAL) (string-append (rexp-arg) "?"))
((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
(else (lose))))))
(else (lose)))))
-\f
+
(define (case-fold-string s)
(let ((end (string-length s)))
(let loop ((start 0) (parts '()))
(re-quote-string
(substring s start index))
parts))
- (apply string-append (reverse! parts)))))))
-
-(define (separated-append tokens separator)
- (cond ((not (pair? tokens)) "")
- ((not (pair? (cdr tokens))) (car tokens))
- (else
- (let ((string
- (make-string
- (let ((ns (string-length separator)))
- (do ((tokens (cdr tokens) (cdr tokens))
- (count (string-length (car tokens))
- (fix:+ count
- (fix:+ (string-length (car tokens))
- ns))))
- ((not (pair? tokens)) count))))))
- (let loop
- ((tokens (cdr tokens))
- (index (string-move! (car tokens) string 0)))
- (if (pair? tokens)
- (loop (cdr tokens)
- (string-move! (car tokens)
- string
- (string-move! separator string index)))))
- string))))
\ No newline at end of file
+ (apply string-append (reverse! parts)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: url.scm,v 1.6 2000/04/13 16:58:40 cph Exp $
+;;; $Id: url.scm,v 1.7 2000/04/14 01:45:49 cph Exp $
;;;
;;; Copyright (c) 2000 Massachusetts Institute of Technology
;;;
url:char-set:escaped)))
(if index
(begin
- (substring-move-left! string start index encoded i)
+ (substring-move! string start index encoded i)
(let ((i (fix:+ i (fix:- index start)))
(code (vector-8b-ref string index)))
(string-set! encoded i #\%)
(fix:+ i 2)
(string-ref digits (fix:and code #x0F)))
(loop (fix:+ index 1) (fix:+ i 3))))
- (substring-move-left! string start end
- encoded i))))
+ (substring-move! string start end encoded i))))
encoded))))
(define (url:decode-substring string start end)
(let ((regs (re-substring-search-forward patt string start end)))
(if regs
(let ((index (re-match-start-index 0 regs)))
- (substring-move-left! string start index decoded i)
+ (substring-move! string start index decoded i)
(let ((i (fix:+ i (fix:- index start))))
(vector-8b-set!
decoded i
(fix:+ index 3)
16))
(loop (fix:+ index 3) (fix:+ i 1))))
- (substring-move-left! string start end decoded i))))
+ (substring-move! string start end decoded i))))
decoded)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff