From: Chris Hanson Date: Fri, 14 Apr 2000 01:45:49 +0000 (+0000) Subject: Use new runtime procedures SUBSTRING-MOVE! and X-Git-Tag: 20090517-FFI~4017 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8783009da37e3436caa03e0d9ac611d47f33816b;p=mit-scheme.git Use new runtime procedures SUBSTRING-MOVE! and DECORATED-STRING-APPEND. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index b2d58af9a..a6791c112 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.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 ;;; @@ -533,7 +533,8 @@ '("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)) @@ -729,10 +730,11 @@ (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))))) (define (header-field-name? object) (and (string? object) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index c12e6fb58..6c7352c3e 100644 --- a/v7/src/imail/imail-rmail.scm +++ b/v7/src/imail/imail-rmail.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -70,9 +70,9 @@ (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" diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index b18b63fd7..a60db506d 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.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 ;;; @@ -385,7 +385,8 @@ With prefix argument N moves forward N messages with these flags." (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. @@ -496,7 +497,8 @@ With prefix argument N moves backward N messages with these 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"))))) diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index b3287aec2..33ccb3944 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -121,7 +121,7 @@ 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))) @@ -144,68 +144,7 @@ (write-char #\: port) (write-string value port) (newline port)) - -(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) - "")) - + (define (read-lines port) (source->list (lambda () (read-line port)))) diff --git a/v7/src/imail/rexp.scm b/v7/src/imail/rexp.scm index 6b695ba19..9d7ace812 100644 --- a/v7/src/imail/rexp.scm +++ b/v7/src/imail/rexp.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -167,7 +167,8 @@ (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) "?")) @@ -193,7 +194,7 @@ ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type))) (else (lose)))))) (else (lose))))) - + (define (case-fold-string s) (let ((end (string-length s))) (let loop ((start 0) (parts '())) @@ -210,27 +211,4 @@ (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 diff --git a/v7/src/imail/rfc822.scm b/v7/src/imail/rfc822.scm index 533214ae2..c1aa6377a 100644 --- a/v7/src/imail/rfc822.scm +++ b/v7/src/imail/rfc822.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -30,7 +30,7 @@ (define (rfc822-addresses->string addresses) (if (null? addresses) "" - (separated-append addresses ", "))) + (decorated-string-append "" ", " "" addresses))) (define (string->rfc822-addresses string) (let ((address-list @@ -70,9 +70,12 @@ (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) diff --git a/v7/src/imail/url.scm b/v7/src/imail/url.scm index c09fbd1d2..01a09aabd 100644 --- a/v7/src/imail/url.scm +++ b/v7/src/imail/url.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -105,7 +105,7 @@ 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 #\%) @@ -116,8 +116,7 @@ (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) @@ -136,7 +135,7 @@ (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 @@ -145,5 +144,5 @@ (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 diff --git a/v7/src/runtime/rexp.scm b/v7/src/runtime/rexp.scm index 6b695ba19..9d7ace812 100644 --- a/v7/src/runtime/rexp.scm +++ b/v7/src/runtime/rexp.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -167,7 +167,8 @@ (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) "?")) @@ -193,7 +194,7 @@ ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type))) (else (lose)))))) (else (lose))))) - + (define (case-fold-string s) (let ((end (string-length s))) (let loop ((start 0) (parts '())) @@ -210,27 +211,4 @@ (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 diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm index c09fbd1d2..01a09aabd 100644 --- a/v7/src/runtime/url.scm +++ b/v7/src/runtime/url.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -105,7 +105,7 @@ 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 #\%) @@ -116,8 +116,7 @@ (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) @@ -136,7 +135,7 @@ (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 @@ -145,5 +144,5 @@ (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