From 55cf0719f88509f8767201ad15abe792339e6078 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 12 Jun 2006 04:19:43 +0000 Subject: [PATCH] Change or eliminate some calls to REDUCE and FOLD-LEFT that might cause trouble with the SRFI-1 definitions. --- v7/src/edwin/debug.scm | 6 +++--- v7/src/edwin/dired.scm | 7 +++++-- v7/src/edwin/notify.scm | 21 +++++++++++---------- v7/src/edwin/sendmail.scm | 32 +++++++++++++++----------------- v7/src/edwin/vc.scm | 9 +++++---- v7/src/pcsample/pcsdisp.scm | 16 ++++++---------- v7/src/pcsample/zones.scm | 5 +---- 7 files changed, 46 insertions(+), 50 deletions(-) diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index 0b849c444..2774b9944 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: debug.scm,v 1.69 2005/04/01 05:06:57 cph Exp $ +$Id: debug.scm,v 1.70 2006/06/12 04:19:43 cph Exp $ Copyright 1992,1993,1994,1995,1996,1997 Massachusetts Institute of Technology Copyright 1998,1999,2000,2001,2002,2003 Massachusetts Institute of Technology -Copyright 2004,2005 Massachusetts Institute of Technology +Copyright 2004,2005,2006 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -1710,7 +1710,7 @@ once it has been renamed, it will not be deleted automatically.") names '()))) env-list)) - (names2 (reduce append '() names1)) + (names2 (reduce-right append '() names1)) (names3 (let loop ((l names2)) (if (null? l) l diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm index ff0a41e3b..474765230 100644 --- a/v7/src/edwin/dired.scm +++ b/v7/src/edwin/dired.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dired.scm,v 1.198 2006/06/11 03:06:23 cph Exp $ +$Id: dired.scm,v 1.199 2006/06/12 04:19:43 cph Exp $ Copyright 1987,1989,1991,1992,1993,1994 Massachusetts Institute of Technology Copyright 1995,1996,1997,1999,2000,2001 Massachusetts Institute of Technology @@ -511,7 +511,10 @@ With a prefix argument you can edit the current listing switches instead." (string-append (string-head (car switches) index) (string-tail (car switches) (fix:+ index 1)))) - (s2 (reduce string-append-separated "" (cdr switches)))) + (s2 + (reduce-right string-append-separated + "" + (cdr switches)))) (if (string=? "-" s1) s2 (string-append-separated s1 s2))) diff --git a/v7/src/edwin/notify.scm b/v7/src/edwin/notify.scm index a7144c5ea..e828e0b73 100644 --- a/v7/src/edwin/notify.scm +++ b/v7/src/edwin/notify.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: notify.scm,v 1.23 2003/02/14 18:28:12 cph Exp $ +$Id: notify.scm,v 1.24 2006/06/12 04:19:43 cph Exp $ -Copyright 1992-2001 Massachusetts Institute of Technology +Copyright 1992,1993,1994,1995,1996,2001 Massachusetts Institute of Technology +Copyright 2006 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -185,14 +186,14 @@ which can show various things including time, load average, and mail status." (define (notifier) (update-notifier-strings! - (reduce string-append-separated - "" - (map (lambda (element) - (if (and (car element) - (variable-value (car element))) - ((cdr element)) - "")) - notifier-elements)) + (reduce-right string-append-separated + "" + (map (lambda (element) + (if (and (car element) + (variable-value (car element))) + ((cdr element)) + "")) + notifier-elements)) (if (and mail-notify-hook-installed? (ref-variable notify-show-mail)) (notifier:mail-present) diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm index 5b117dfc1..3af2eabed 100644 --- a/v7/src/edwin/sendmail.scm +++ b/v7/src/edwin/sendmail.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: sendmail.scm,v 1.86 2005/10/24 02:23:41 cph Exp $ +$Id: sendmail.scm,v 1.87 2006/06/12 04:19:43 cph Exp $ Copyright 1991,1992,1993,1994,1995,1996 Massachusetts Institute of Technology Copyright 1997,1998,2000,2001,2003,2004 Massachusetts Institute of Technology -Copyright 2005 Massachusetts Institute of Technology +Copyright 2005,2006 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -111,21 +111,19 @@ Otherwise, only one valid recipient is required." (define-variable mail-yank-ignored-headers "Delete these headers from old message when it's inserted in a reply." - (reduce (lambda (x y) (string-append x "\\|" y)) - "" - '("^via:" - "^mail-from:" - "^origin:" - "^status:" - "^remailed" - "^received:" - "^[a-z-]*message-id:" - "^summary-line:" - "^to:" - "^cc:" - "^subject:" - "^in-reply-to:" - "^return-path:")) + (regexp-group "^via:" + "^mail-from:" + "^origin:" + "^status:" + "^remailed" + "^received:" + "^[a-z-]*message-id:" + "^summary-line:" + "^to:" + "^cc:" + "^subject:" + "^in-reply-to:" + "^return-path:") string?) (define-variable mail-interactive diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm index 5c7d10460..65df473fc 100644 --- a/v7/src/edwin/vc.scm +++ b/v7/src/edwin/vc.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: vc.scm,v 1.92 2006/05/31 01:19:39 cph Exp $ +$Id: vc.scm,v 1.93 2006/06/12 04:19:43 cph Exp $ Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology Copyright 2001,2002,2003,2005,2006 Massachusetts Institute of Technology @@ -2395,9 +2395,10 @@ the value of vc-log-mode-hook." (define (vc-run-shell-command master options command . arguments) (vc-run-command master options "/bin/sh" "-c" - (reduce string-append-separated - "" - (vc-command-arguments (cons command arguments))))) + (reduce-right string-append-separated + "" + (vc-command-arguments + (cons command arguments))))) (define (pop-up-vc-command-buffer select?) (let ((buffer (get-vc-command-buffer))) diff --git a/v7/src/pcsample/pcsdisp.scm b/v7/src/pcsample/pcsdisp.scm index 0dc5b9884..4d747d42b 100644 --- a/v7/src/pcsample/pcsdisp.scm +++ b/v7/src/pcsample/pcsdisp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: pcsdisp.scm,v 1.5 2003/02/14 18:28:31 cph Exp $ +$Id: pcsdisp.scm,v 1.6 2006/06/12 04:19:43 cph Exp $ -Copyright (c) 1993, 1999 Massachusetts Institute of Technology +Copyright 1993,1999,2006 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -411,10 +411,9 @@ USA. `(CODE-BLOCK ,ID TRAMPOLINE) (cddr samples))) (else '()))) - (tramp-tally (reduce (lambda (elt so-far) ; tally # samples - (flo:+ so-far (second elt))) - 0. - tramps))) + ;; tally # samples + (tramp-tally (apply + (map second tramps)))) + (if (null? tramps) (no-trampolines-of-sort ID-string) `(,ID-fnord! ,tramp-tally ,@tramps)))) @@ -628,10 +627,7 @@ USA. #| ;; Reality check... ;; Do: (apply + (map car lst))... reality check... - (let ((total-count (car (reduce (lambda (stat tacc) - `(,(flo:+ (car stat) (car tacc)))) - '(0.) - sorted-status)))) + (let ((total-count (apply + (map car sorted-status)))) (cond ((not (flo:= total-count tally)) (warn "; Damned total-count != tally. Foo." total-count tally)))) |# diff --git a/v7/src/pcsample/zones.scm b/v7/src/pcsample/zones.scm index e03fd165f..c164879ee 100644 --- a/v7/src/pcsample/zones.scm +++ b/v7/src/pcsample/zones.scm @@ -118,10 +118,7 @@ (define (display-zone-report) (read-zone-counts!) (let ((zones (get-zones))) - (let ((total - (fold-left (lambda (sum zone) (+ sum (pc-sample-zone/count zone))) - 0 - zones))) + (let ((total (apply + (map pc-sample-zone/count zones)))) (let ((pct (if (zero? total) (lambda (zone) zone 0) (lambda (zone) -- 2.25.1