From: Chris Hanson Date: Thu, 13 Feb 2003 19:59:00 +0000 (+0000) Subject: Add support for SRFI-6 -- this consists of renaming some procedures. X-Git-Tag: 20090517-FFI~2031 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9f9114c56b221baf1692652d4f97b5ee95559ea8;p=mit-scheme.git Add support for SRFI-6 -- this consists of renaming some procedures. Also change all the references to the SRFI-6 names. --- diff --git a/v7/src/6001/nodefs.scm b/v7/src/6001/nodefs.scm index 0e1bbffc3..23e82abf8 100644 --- a/v7/src/6001/nodefs.scm +++ b/v7/src/6001/nodefs.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: nodefs.scm,v 1.13 2002/11/20 19:45:46 cph Exp $ +$Id: nodefs.scm,v 1.14 2003/02/13 19:56:06 cph Exp $ -Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology +Copyright 1991,1992,1993,1995,2001,2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -69,7 +69,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. expression))) (define (write-definition-value name #!optional value) - (with-string-output-port + (call-with-output-string (lambda (port) (write name port) (if (not (default-object? value)) diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm index d5d355081..47e9a78fa 100644 --- a/v7/src/edwin/hlpcom.scm +++ b/v7/src/edwin/hlpcom.scm @@ -1,25 +1,27 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: hlpcom.scm,v 1.124 2002/11/20 19:46:00 cph Exp $ -;;; -;;; Copyright (c) 1986, 1989-2002 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: hlpcom.scm,v 1.125 2003/02/13 19:53:57 cph Exp $ + +Copyright 1986,1989,1990,1991,1993,1998 Massachusetts Institute of Technology +Copyright 2000,2002,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; Help Commands @@ -398,13 +400,13 @@ If you want VALUE to be a string, you must surround it with doublequotes." (show-bindings (lambda (argument next comtabs) comtabs - (cons (let ((port (make-accumulator-output-port))) - (describe-bindings - (mode-comtabs (name->mode argument 'ERROR)) - #f - port) - (newline port) - (get-output-from-accumulator port)) + (cons (call-with-output-string + (lambda (port) + (describe-bindings + (mode-comtabs (name->mode argument 'ERROR)) + #f + port) + (newline port))) (find-escape next comtabs)))) (new-mode (lambda (argument next comtabs) diff --git a/v7/src/edwin/nntp.scm b/v7/src/edwin/nntp.scm index 4e7347bd2..3d6455967 100644 --- a/v7/src/edwin/nntp.scm +++ b/v7/src/edwin/nntp.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: nntp.scm,v 1.25 2002/11/20 19:46:01 cph Exp $ -;;; -;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: nntp.scm,v 1.26 2003/02/13 19:54:04 cph Exp $ + +Copyright 1995,1996,1997,1998,1999,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; NNTP Interface @@ -261,9 +262,9 @@ (caddr tokens) (if prune? (header-lines->text (nntp-read-text-lines connection)) - (with-string-output-port - (lambda (port) - (nntp-read-text connection port #f))))))) + (call-with-output-string + (lambda (port) + (nntp-read-text connection port #f))))))) ((423 430) 'NO-SUCH-ARTICLE) (else @@ -840,14 +841,14 @@ (define (pre-read-body group key) (let ((valid?)) (let ((datum - (with-string-output-port - (lambda (port) - (maybe-switch-groups group) - (set! valid? - (nntp-body-command (news-group:connection group) - key - port)) - unspecific)))) + (call-with-output-string + (lambda (port) + (maybe-switch-groups group) + (set! valid? + (nntp-body-command (news-group:connection group) + key + port)) + unspecific)))) (and valid? (begin (gdbm-store (news-group:body-gdbf group #t) key datum diff --git a/v7/src/edwin/rfc822.scm b/v7/src/edwin/rfc822.scm index dc44b09bd..755435369 100644 --- a/v7/src/edwin/rfc822.scm +++ b/v7/src/edwin/rfc822.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: rfc822.scm,v 3.4 2002/11/20 19:46:02 cph Exp $ -;;; -;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: rfc822.scm,v 3.5 2003/02/13 19:54:10 cph Exp $ + +Copyright 1999,2000,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; IMAIL mail reader: RFC-822 support @@ -288,19 +289,19 @@ ;;;; Token-stream filters (define (rfc822:tokens->string tokens) - (let ((port (make-accumulator-output-port))) - (do ((tokens tokens (cdr tokens))) - ((not (pair? tokens))) - (cond ((char? (car tokens)) - (write-char (car tokens) port)) - ((string? (car tokens)) - (write-string (car tokens) port)) - ((and (pair? (car tokens)) - (eq? 'ILLEGAL (caar tokens))) - (write-char (cdar tokens) port)) - (else - (error "Malformed RFC-822 token stream:" tokens)))) - (get-output-from-accumulator port))) + (call-with-output-string + (lambda (port) + (do ((tokens tokens (cdr tokens))) + ((not (pair? tokens))) + (cond ((char? (car tokens)) + (write-char (car tokens) port)) + ((string? (car tokens)) + (write-string (car tokens) port)) + ((and (pair? (car tokens)) + (eq? 'ILLEGAL (caar tokens))) + (write-char (cdar tokens) port)) + (else + (error "Malformed RFC-822 token stream:" tokens))))))) (define rfc822:strip-whitespace! (list-deletor! @@ -372,7 +373,7 @@ (and (not (eof-object? char)) (char-lwsp? char)))))) (lambda (input-string) - (let ((port (string->input-port input-string))) + (let ((port (open-input-string input-string))) (define (dispatch) (let ((char (input-port/read-char port))) (cond ((eof-object? char) diff --git a/v7/src/edwin/schmod.scm b/v7/src/edwin/schmod.scm index da1dd8f64..a5911cf95 100644 --- a/v7/src/edwin/schmod.scm +++ b/v7/src/edwin/schmod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: schmod.scm,v 1.61 2003/01/15 04:52:25 cph Exp $ +$Id: schmod.scm,v 1.62 2003/02/13 19:58:30 cph Exp $ Copyright 1986,1989,1990,1991,1992,1998 Massachusetts Institute of Technology Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology @@ -171,7 +171,7 @@ The following commands evaluate Scheme expressions: NAMED-LAMBDA) ;; MIT Scheme procedures: - (0 WITH-OUTPUT-TO-STRING) + (0 CALL-WITH-OUTPUT-STRING WITH-OUTPUT-TO-STRING) (1 CALL-WITH-APPEND-FILE CALL-WITH-BINARY-APPEND-FILE CALL-WITH-BINARY-INPUT-FILE CALL-WITH-BINARY-OUTPUT-FILE WITH-INPUT-FROM-PORT WITH-INPUT-FROM-STRING WITH-OUTPUT-TO-PORT diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm index a1bdc417f..210606d5f 100644 --- a/v7/src/edwin/sendmail.scm +++ b/v7/src/edwin/sendmail.scm @@ -1,25 +1,27 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: sendmail.scm,v 1.79 2002/11/20 19:46:03 cph Exp $ -;;; -;;; Copyright (c) 1991-2001 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: sendmail.scm,v 1.80 2003/02/13 19:54:17 cph Exp $ + +Copyright 1991,1992,1993,1994,1995,1996 Massachusetts Institute of Technology +Copyright 1997,1998,2000,2001,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; Mail Sending @@ -1335,13 +1337,13 @@ the user from the mailer." (if (not (<= 1 length (- 70 plen))) (error:bad-range-argument length 'RANDOM-MIME-BOUNDARY-STRING)) (let ((s - (with-string-output-port - (lambda (port) - (write-string prefix port) - (let ((context (encode-base64:initialize port #f))) - (let ((n (* (integer-ceiling (- length 2) 4) 3))) - (encode-base64:update context (random-byte-vector n) 0 n)) - (encode-base64:finalize context))))) + (call-with-output-string + (lambda (port) + (write-string prefix port) + (let ((context (encode-base64:initialize port #f))) + (let ((n (* (integer-ceiling (- length 2) 4) 3))) + (encode-base64:update context (random-byte-vector n) 0 n)) + (encode-base64:finalize context))))) (n (+ plen length))) (if (fix:> (string-length s) n) (set-string-maximum-length! s n)) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 89b387b69..d0e6f6873 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: imail-core.scm,v 1.147 2002/11/20 19:46:05 cph Exp $ -;;; -;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: imail-core.scm,v 1.148 2003/02/13 19:54:36 cph Exp $ + +Copyright 1999,2000,2001,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; IMAIL mail reader: core definitions @@ -649,10 +650,10 @@ (set-message-folder! message #f)) (define (message->string message) - (with-string-output-port - (lambda (port) - (write-header-fields (message-header-fields message) port) - (write-message-body message port)))) + (call-with-output-string + (lambda (port) + (write-header-fields (message-header-fields message) port) + (write-message-body message port)))) (define (message-time message) (let ((date (get-first-header-field-value message "date" #f))) @@ -951,21 +952,21 @@ (write-substring string start end port)))) (define (header-fields->string headers) - (with-string-output-port - (lambda (port) - (write-header-fields headers port)))) + (call-with-output-string + (lambda (port) + (write-header-fields headers port)))) (define (header-field->string header) - (with-string-output-port - (lambda (port) - (write-header-field header port)))) + (call-with-output-string + (lambda (port) + (write-header-field header port)))) (define (header-field-value->string value) - (with-string-output-port - (lambda (port) - (encode-header-field-value value - (lambda (string start end) - (write-substring string start end port)))))) + (call-with-output-string + (lambda (port) + (encode-header-field-value value + (lambda (string start end) + (write-substring string start end port)))))) (define (get-first-header-field headers name error?) (let loop ((headers (->header-fields headers))) diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index a3cc8e310..cb3345b27 100644 --- a/v7/src/imail/imail-file.scm +++ b/v7/src/imail/imail-file.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: imail-file.scm,v 1.82 2002/11/20 19:46:05 cph Exp $ -;;; -;;; Copyright (c) 1999-2002 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: imail-file.scm,v 1.83 2003/02/13 19:54:43 cph Exp $ + +Copyright 1999,2000,2001,2002,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; IMAIL mail reader: file-based folder support @@ -527,9 +528,9 @@ (lambda (s) s)) (define-method file-message-body ((message )) - (with-string-output-port - (lambda (port) - (write-message-body message port)))) + (call-with-output-string + (lambda (port) + (write-message-body message port)))) (define-method write-message-body ((message ) port) (write-string (file-message-body message) port)) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index e5bca3378..e6d2c712a 100644 --- a/v7/src/imail/imail-imap.scm +++ b/v7/src/imail/imail-imap.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: imail-imap.scm,v 1.196 2002/11/20 19:46:05 cph Exp $ -;;; -;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: imail-imap.scm,v 1.197 2003/02/13 19:54:50 cph Exp $ + +Copyright 1999,2000,2001,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; IMAIL mail reader: IMAP back end @@ -1695,22 +1696,22 @@ (encode-cache-namestring (imap-url-mailbox url))))) (define (encode-cache-namestring string) - (with-string-output-port - (lambda (port) - (let ((n (string-length string))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (let ((char (string-ref string i))) - (cond ((char-set-member? char-set:cache-namestring-safe char) - (write-char char port)) - ((char=? char #\/) - (write-char #\# port)) - (else - (write-char #\% port) - (let ((n (char->integer char))) - (if (fix:< n #x10) - (write-char #\0 port)) - (write-string (number->string n 16) port)))))))))) + (call-with-output-string + (lambda (port) + (let ((n (string-length string))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (let ((char (string-ref string i))) + (cond ((char-set-member? char-set:cache-namestring-safe char) + (write-char char port)) + ((char=? char #\/) + (write-char #\# port)) + (else + (write-char #\% port) + (let ((n (char->integer char))) + (if (fix:< n #x10) + (write-char #\0 port)) + (write-string (number->string n 16) port)))))))))) (define char-set:cache-namestring-safe (char-set-union char-set:alphanumeric (string->char-set "-_."))) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index dc6b76e20..a4b4afddf 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.285 2003/01/15 21:26:02 cph Exp $ +$Id: imail-top.scm,v 1.286 2003/02/13 19:54:57 cph Exp $ Copyright 1999,2000,2001,2002,2003 Massachusetts Institute of Technology @@ -262,40 +262,40 @@ regardless of the folder type." (define-major-mode imail read-only "IMAIL" (lambda () - (with-string-output-port - (lambda (port) - (write-string imail-mode-description port) - (newline port) - (newline port) - (write-string (make-string 70 #\-) port) - (newline port) - (write-string "These variables customize the behavior of IMAIL:" port) - (newline port) - (newline port) - (for-each - (let ((buffer (selected-buffer))) - (lambda (variable) - (let ((name (variable-name-string variable))) - (if (not (string-prefix-ci? "imail-summary-" name)) - (begin - (write-string name port) - (newline port) - (write-string " " port) - (write-description - (description-first-line (variable-description variable)) - port) - (newline port) - (write-string " Value: " port) - (write (variable-local-value buffer variable) port) - (newline port) - (newline port)))))) - (string-table-apropos editor-variables "^imail-")) - (write-string (make-string 70 #\-) port) - (newline port) - (write-string "These are all the key bindings for IMAIL mode:" port) - (newline port) - (newline port) - (write-string "\\{imail}" port)))) + (call-with-output-string + (lambda (port) + (write-string imail-mode-description port) + (newline port) + (newline port) + (write-string (make-string 70 #\-) port) + (newline port) + (write-string "These variables customize the behavior of IMAIL:" port) + (newline port) + (newline port) + (for-each + (let ((buffer (selected-buffer))) + (lambda (variable) + (let ((name (variable-name-string variable))) + (if (not (string-prefix-ci? "imail-summary-" name)) + (begin + (write-string name port) + (newline port) + (write-string " " port) + (write-description + (description-first-line (variable-description variable)) + port) + (newline port) + (write-string " Value: " port) + (write (variable-local-value buffer variable) port) + (newline port) + (newline port)))))) + (string-table-apropos editor-variables "^imail-")) + (write-string (make-string 70 #\-) port) + (newline port) + (write-string "These are all the key bindings for IMAIL mode:" port) + (newline port) + (newline port) + (write-string "\\{imail}" port)))) (lambda (buffer) (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-revert-buffer) (add-kill-buffer-hook buffer imail-kill-buffer) @@ -2597,12 +2597,12 @@ Negative argument means search in reverse." (define-method insert-mime-message-inline* (message (body ) selector context mark) - (insert-header-fields (with-string-output-port - (lambda (port) - (write-mime-message-body-part message - `(,@selector HEADER) - #t - port))) + (insert-header-fields (call-with-output-string + (lambda (port) + (write-mime-message-body-part message + `(,@selector HEADER) + #t + port))) #f mark) (walk-mime-message-part message diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm index f8e4d4f8d..470b35d13 100644 --- a/v7/src/imail/imap-response.scm +++ b/v7/src/imail/imap-response.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: imap-response.scm,v 1.46 2002/11/20 19:46:06 cph Exp $ -;;; -;;; Copyright (c) 2000-2002 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: imap-response.scm,v 1.47 2003/02/13 19:55:04 cph Exp $ + +Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; IMAP Server Response Reader @@ -262,9 +263,9 @@ (else (error "Illegal astring syntax:" char))))) (define (read-nstring input) - (let ((output (make-accumulator-output-port))) + (let ((output (open-output-string))) (and (read-nstring-to-port input output) - (get-output-from-accumulator output)))) + (get-output-string output)))) (define (read-nstring-to-port input output) (let ((char (peek-char-no-eof input))) @@ -282,9 +283,9 @@ (else (error "Illegal astring syntax:" char))))) (define (read-quoted input) - (with-string-output-port - (lambda (output) - (read-quoted-to-port input output)))) + (call-with-output-string + (lambda (output) + (read-quoted-to-port input output)))) (define (read-quoted-to-port input output) (discard-known-char #\" input) @@ -305,9 +306,9 @@ (lose))))))) (define (read-literal input) - (with-string-output-port - (lambda (output) - (read-literal-to-port input output)))) + (call-with-output-string + (lambda (output) + (read-literal-to-port input output)))) (define (read-literal-to-port input output) (discard-known-char #\{ input) diff --git a/v7/src/microcode/makegen/makegen.scm b/v7/src/microcode/makegen/makegen.scm index f7375c589..c496f738b 100644 --- a/v7/src/microcode/makegen/makegen.scm +++ b/v7/src/microcode/makegen/makegen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: makegen.scm,v 1.4 2002/11/20 19:46:17 cph Exp $ +$Id: makegen.scm,v 1.5 2003/02/13 19:56:29 cph Exp $ -Copyright (c) 2000, 2001 Massachusetts Institute of Technology +Copyright 2000,2001,2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -140,10 +140,10 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (define (generate-rule filename) (parse-rule (unbreak-lines - (with-string-output-port - (lambda (port) - (run-shell-command (string-append "gcc -M -DMIT_SCHEME " filename) - 'OUTPUT port)))))) + (call-with-output-string + (lambda (port) + (run-shell-command (string-append "gcc -M -DMIT_SCHEME " filename) + 'OUTPUT port)))))) (define (unbreak-lines string) (let ((indexes (string-search-all "\\\n" string))) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index ff08715a1..e334a8d48 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,8 +1,10 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.59 2003/01/01 02:26:37 cph Exp $ +$Id: error.scm,v 14.60 2003/02/13 19:52:29 cph Exp $ -Copyright (c) 1988-2002 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 1992,1993,1995,2000,2001,2002 Massachusetts Institute of Technology +Copyright 2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -271,9 +273,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (reporter condition port)))) (define (condition/report-string condition) - (with-string-output-port - (lambda (port) - (write-condition-report condition port)))) + (call-with-output-string + (lambda (port) + (write-condition-report condition port)))) ;;;; Restarts diff --git a/v7/src/runtime/mit-syntax.scm b/v7/src/runtime/mit-syntax.scm index 4a7c878d9..715fedbd9 100644 --- a/v7/src/runtime/mit-syntax.scm +++ b/v7/src/runtime/mit-syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: mit-syntax.scm,v 14.12 2003/02/13 02:46:41 cph Exp $ +$Id: mit-syntax.scm,v 14.13 2003/02/13 19:52:35 cph Exp $ Copyright 1989,1990,1991,2001,2002,2003 Massachusetts Institute of Technology @@ -314,7 +314,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (if-error) (loop (cdr clauses)))))) (cond ((identifier? req) - (if (there-exists? supported-features + (if (there-exists? supported-srfi-features (lambda (feature) (compare (rename feature) req))) (if-true) @@ -344,8 +344,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (if-error))))))) (if-error))))) -(define supported-features +(define supported-srfi-features '(SRFI-0 + SRFI-6 SRFI-8 SRFI-9 SRFI-23 diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index cdf64eff3..e9bd3f5c0 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,8 +1,10 @@ #| -*-Scheme-*- -$Id: parse.scm,v 14.38 2002/11/20 19:46:21 cph Exp $ +$Id: parse.scm,v 14.39 2003/02/13 19:52:43 cph Exp $ -Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 1992,1993,1994,1997,1998,1999 Massachusetts Institute of Technology +Copyright 2001,2002,2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -519,7 +521,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (let ((head (read-string char-set/string-delimiters))) (if (char=? #\" (read-char)) head - (with-string-output-port + (call-with-output-string (lambda (port) (write-string head port) (let loop () diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index 33674ee72..42f77b5bf 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,8 +1,10 @@ #| -*-Scheme-*- -$Id: pp.scm,v 14.44 2002/11/20 19:46:22 cph Exp $ +$Id: pp.scm,v 14.45 2003/02/13 19:52:50 cph Exp $ -Copyright (c) 1988-2001 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 1992,1993,1994,1995,1996,1999 Massachusetts Institute of Technology +Copyright 2001,2002,2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -684,7 +686,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (numerical-walk-no-auto-highlight object list-depth)))) (define (walk-custom unparser object list-depth) - (with-string-output-port + (call-with-output-string (lambda (port) (unparser (make-unparser-state port list-depth diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index e615e97aa..7433bf0dc 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.425 2003/02/10 01:54:05 cph Exp $ +$Id: runtime.pkg,v 14.426 2003/02/13 19:52:58 cph Exp $ Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology @@ -3749,7 +3749,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (files "strnin") (parent (runtime)) (export () - string->input-port + open-input-string + (string->input-port open-input-string) with-input-from-string) (initialization (initialize-package!))) @@ -3757,9 +3758,12 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (files "strout") (parent (runtime)) (export () - get-output-from-accumulator - make-accumulator-output-port - with-string-output-port + call-with-output-string + (get-output-from-accumulator get-output-string) + get-output-string + (make-accumulator-output-port open-output-string) + open-output-string + (with-string-output-port call-with-output-string) with-output-to-string) (initialization (initialize-package!))) @@ -3793,6 +3797,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. reverse-syntactic-environments rsc-macro-transformer->expander strip-syntactic-closures + supported-srfi-features syntactic-closure-rtd syntactic-closure/environment syntactic-closure/free-names diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm index af6a7334b..caf5bb225 100644 --- a/v7/src/runtime/strnin.scm +++ b/v7/src/runtime/strnin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: strnin.scm,v 14.9 2002/11/20 19:46:23 cph Exp $ +$Id: strnin.scm,v 14.10 2003/02/13 19:53:05 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright 1988,1990,1993,1999,2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -22,7 +22,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |# -;;;; String I/O Ports +;;;; String Input Ports (SRFI-6) ;;; package: (runtime string-input) (declare (usual-integrations)) @@ -40,19 +40,19 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. unspecific) (define (with-input-from-string string thunk) - (with-input-from-port (string->input-port string) thunk)) + (with-input-from-port (open-input-string string) thunk)) -(define (string->input-port string #!optional start end) +(define (open-input-string string #!optional start end) (let ((end (if (default-object? end) (string-length string) - (check-index end (string-length string) 'STRING->INPUT-PORT)))) + (check-index end (string-length string) 'OPEN-INPUT-STRING)))) (make-port input-string-port-type (make-input-string-state string (if (default-object? start) 0 - (check-index start end 'STRING->INPUT-PORT)) + (check-index start end 'OPEN-INPUT-STRING)) end)))) (define (check-index index limit procedure) diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm index b37bb7970..7d40ddef0 100644 --- a/v7/src/runtime/strout.scm +++ b/v7/src/runtime/strout.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: strout.scm,v 14.16 2002/11/20 19:46:23 cph Exp $ +$Id: strout.scm,v 14.17 2003/02/13 19:53:12 cph Exp $ -Copyright (c) 1988-2001 Massachusetts Institute of Technology +Copyright 1988,1990,1993,1999,2000,2001 Massachusetts Institute of Technology +Copyright 2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -22,25 +23,25 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |# -;;;; String Output Ports +;;;; String Output Ports (SRFI-6) ;;; package: (runtime string-output) (declare (usual-integrations)) -(define (make-accumulator-output-port) +(define (open-output-string) (make-port accumulator-output-port-type (make-accumulator-state (make-string 16) 0))) -(define (get-output-from-accumulator port) +(define (get-output-string port) ((port/operation port 'EXTRACT-OUTPUT!) port)) (define (with-output-to-string thunk) - (with-string-output-port (lambda (port) (with-output-to-port port thunk)))) + (call-with-output-string (lambda (port) (with-output-to-port port thunk)))) -(define (with-string-output-port generator) - (let ((port (make-accumulator-output-port))) +(define (call-with-output-string generator) + (let ((port (open-output-string))) (generator port) - (operation/extract-output! port))) + (get-output-string port))) (define accumulator-output-port-type) (define (initialize-package!) diff --git a/v7/src/runtime/unicode.scm b/v7/src/runtime/unicode.scm index 59ece7a3c..d22202d81 100644 --- a/v7/src/runtime/unicode.scm +++ b/v7/src/runtime/unicode.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: unicode.scm,v 1.3 2002/11/20 19:46:23 cph Exp $ -;;; -;;; Copyright (c) 2001 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: unicode.scm,v 1.4 2003/02/13 19:53:19 cph Exp $ + +Copyright 2001,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; Unicode support @@ -408,7 +409,7 @@ (error "Illegal initial UTF-8 char:" c0))))) (define (utf8-string->code-point string) - (read-utf8-code-point (string->input-port string))) + (read-utf8-code-point (open-input-string string))) (define (read-utf8-code-point-from-source source) ;; This is separately implemented to speed up the parser buffer. @@ -515,6 +516,6 @@ (output-8b (subsequent-char 0))))) (define (code-point->utf8-string n) - (with-string-output-port + (call-with-output-string (lambda (port) (write-utf8-code-point n port)))) diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm index 217808f2b..534bb0464 100644 --- a/v7/src/xml/xml-output.scm +++ b/v7/src/xml/xml-output.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-output.scm,v 1.12 2003/02/07 20:01:59 cph Exp $ +$Id: xml-output.scm,v 1.13 2003/02/13 19:58:54 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -32,7 +32,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (write-xml xml port)))) (define (xml->string xml) - (with-string-output-port + (call-with-output-string (lambda (port) (write-xml xml port)))) diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm index 4bbfef8d8..07b049d19 100644 --- a/v7/src/xml/xml-parser.scm +++ b/v7/src/xml/xml-parser.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-parser.scm,v 1.19 2003/02/07 20:02:14 cph Exp $ +$Id: xml-parser.scm,v 1.20 2003/02/13 19:59:00 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -527,50 +527,50 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;;; Normalization (define (normalize-attribute-value value p) - (with-string-output-port - (lambda (port) - (let normalize-value ((value value)) - (if (string? value) - (let ((buffer - (string->parser-buffer (normalize-line-endings value)))) - (let loop () - (let ((char (peek-parser-buffer-char buffer))) - (cond ((not char) - unspecific) - ((or (char=? char #\tab) - (char=? char #\newline)) - (write-char #\space port) - (read-parser-buffer-char buffer) - (loop)) - ((char=? char #\&) - (normalize-value - (vector-ref (parse-reference buffer) - 0)) - (loop)) - (else - (write-char char port) - (read-parser-buffer-char buffer) - (loop)))))) - (perror p "Reference to external entity in attribute")))))) + (call-with-output-string + (lambda (port) + (let normalize-value ((value value)) + (if (string? value) + (let ((buffer + (string->parser-buffer (normalize-line-endings value)))) + (let loop () + (let ((char (peek-parser-buffer-char buffer))) + (cond ((not char) + unspecific) + ((or (char=? char #\tab) + (char=? char #\newline)) + (write-char #\space port) + (read-parser-buffer-char buffer) + (loop)) + ((char=? char #\&) + (normalize-value + (vector-ref (parse-reference buffer) + 0)) + (loop)) + (else + (write-char char port) + (read-parser-buffer-char buffer) + (loop)))))) + (perror p "Reference to external entity in attribute")))))) (define (trim-attribute-whitespace string) - (with-string-output-port - (lambda (port) - (let ((string (string-trim string))) - (let ((end (string-length string))) - (let loop ((start 0)) - (if (fix:< start end) - (let ((regs - (re-substring-search-forward " +" string start end))) - (if regs - (begin - (write-substring string - start - (re-match-start-index 0 regs) - port) - (write-char #\space port) - (loop (re-match-end-index 0 regs))) - (write-substring string start end port)))))))))) + (call-with-output-string + (lambda (port) + (let ((string (string-trim string))) + (let ((end (string-length string))) + (let loop ((start 0)) + (if (fix:< start end) + (let ((regs + (re-substring-search-forward " +" string start end))) + (if regs + (begin + (write-substring string + start + (re-match-start-index 0 regs) + port) + (write-char #\space port) + (loop (re-match-end-index 0 regs))) + (write-substring string start end port)))))))))) (define (normalize-line-endings string #!optional always-copy?) (if (string-find-next-char string #\return)