module/ice-9/r4rs.scm

   1 ;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
   2 ;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
   3
   4 ;;;;    Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010, 2011 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (eval-when (compile)
  21   (set-current-module (resolve-module '(guile))))
  22
  23 \f
  24 ;;;; apply and call-with-current-continuation
  25
  26 ;;; The deal with these is that they are the procedural wrappers around the
  27 ;;; primitives of Guile's language. There are about 20 different kinds of
  28 ;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
  29 ;;; to preserve tail recursion.)
  30 ;;;
  31 ;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in the
  32 ;;; case that apply is passed to apply, or we're bootstrapping, we need a
  33 ;;; trampoline -- and here they are.
  34 (define (apply fun . args)
  35   (@apply fun (apply:nconc2last args)))
  36 (define (call-with-current-continuation proc)
  37   (@call-with-current-continuation proc))
  38 (define (call-with-values producer consumer)
  39   (@call-with-values producer consumer))
  40 (define (dynamic-wind in thunk out)
  41   "All three arguments must be 0-argument procedures.
  42 Guard @var{in} is called, then @var{thunk}, then
  43 guard @var{out}.
  44
  45 If, any time during the execution of @var{thunk}, the
  46 continuation of the @code{dynamic_wind} expression is escaped
  47 non-locally, @var{out} is called.  If the continuation of
  48 the dynamic-wind is re-entered, @var{in} is called.  Thus
  49 @var{in} and @var{out} may be called any number of
  50 times.
  51 @lisp
  52  (define x 'normal-binding)
  53 @result{} x
  54  (define a-cont
  55    (call-with-current-continuation
  56      (lambda (escape)
  57        (let ((old-x x))
  58          (dynamic-wind
  59            ;; in-guard:
  60            ;;
  61            (lambda () (set! x 'special-binding))
  62
  63            ;; thunk
  64            ;;
  65            (lambda () (display x) (newline)
  66                    (call-with-current-continuation escape)
  67                    (display x) (newline)
  68                    x)
  69
  70            ;; out-guard:
  71            ;;
  72            (lambda () (set! x old-x)))))))
  73
  74 ;; Prints:
  75 special-binding
  76 ;; Evaluates to:
  77 @result{} a-cont
  78 x
  79 @result{} normal-binding
  80  (a-cont #f)
  81 ;; Prints:
  82 special-binding
  83 ;; Evaluates to:
  84 @result{} a-cont  ;; the value of the (define a-cont...)
  85 x
  86 @result{} normal-binding
  87 a-cont
  88 @result{} special-binding
  89 @end lisp"
  90   (@dynamic-wind in (thunk) out))
  91
  92 \f
  93 ;;;; Basic Port Code
  94
  95 ;;; Specifically, the parts of the low-level port code that are written in
  96 ;;; Scheme rather than C.
  97 ;;;
  98 ;;; WARNING: the parts of this interface that refer to file ports
  99 ;;; are going away.   It would be gone already except that it is used
 100 ;;; "internally" in a few places.
 101
 102
 103 ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
 104 ;;; proper mode to open files in.
 105 ;;;
 106 ;;; If we want to support systems that do CRLF->LF translation, like
 107 ;;; Windows, then we should have a symbol in scmconfig.h made visible
 108 ;;; to the Scheme level that we can test here, and autoconf magic to
 109 ;;; #define it when appropriate.  Windows will probably just have a
 110 ;;; hand-generated scmconfig.h file.
 111 (define OPEN_READ "r")
 112 (define OPEN_WRITE "w")
 113 (define OPEN_BOTH "r+")
 114
 115 (define *null-device* "/dev/null")
 116
 117 (define (open-input-file str)
 118   "Takes a string naming an existing file and returns an input port
 119 capable of delivering characters from the file.  If the file
 120 cannot be opened, an error is signalled."
 121   (open-file str OPEN_READ))
 122
 123 (define (open-output-file str)
 124   "Takes a string naming an output file to be created and returns an
 125 output port capable of writing characters to a new file by that
 126 name.  If the file cannot be opened, an error is signalled.  If a
 127 file with the given name already exists, the effect is unspecified."
 128   (open-file str OPEN_WRITE))
 129
 130 (define (open-io-file str)
 131   "Open file with name STR for both input and output."
 132   (open-file str OPEN_BOTH))
 133
 134 (define close-io-port close-port)
 135
 136 (define (call-with-input-file str proc)
 137   "PROC should be a procedure of one argument, and STR should be a
 138 string naming a file.  The file must
 139 already exist. These procedures call PROC
 140 with one argument: the port obtained by opening the named file for
 141 input or output.  If the file cannot be opened, an error is
 142 signalled.  If the procedure returns, then the port is closed
 143 automatically and the values yielded by the procedure are returned.
 144 If the procedure does not return, then the port will not be closed
 145 automatically unless it is possible to prove that the port will
 146 never again be used for a read or write operation."
 147   (let ((p (open-input-file str)))
 148     (call-with-values
 149       (lambda () (proc p))
 150       (lambda vals
 151         (close-input-port p)
 152         (apply values vals)))))
 153
 154 (define (call-with-output-file str proc)
 155   "PROC should be a procedure of one argument, and STR should be a
 156 string naming a file.  The behaviour is unspecified if the file
 157 already exists. These procedures call PROC
 158 with one argument: the port obtained by opening the named file for
 159 input or output.  If the file cannot be opened, an error is
 160 signalled.  If the procedure returns, then the port is closed
 161 automatically and the values yielded by the procedure are returned.
 162 If the procedure does not return, then the port will not be closed
 163 automatically unless it is possible to prove that the port will
 164 never again be used for a read or write operation."
 165   (let ((p (open-output-file str)))
 166     (call-with-values
 167       (lambda () (proc p))
 168       (lambda vals
 169         (close-output-port p)
 170         (apply values vals)))))
 171
 172 (define (with-input-from-port port thunk)
 173   (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
 174     (dynamic-wind swaports thunk swaports)))
 175
 176 (define (with-output-to-port port thunk)
 177   (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
 178     (dynamic-wind swaports thunk swaports)))
 179
 180 (define (with-error-to-port port thunk)
 181   (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
 182     (dynamic-wind swaports thunk swaports)))
 183
 184 (define (with-input-from-file file thunk)
 185   "THUNK must be a procedure of no arguments, and FILE must be a
 186 string naming a file.  The file must already exist. The file is opened for
 187 input, an input port connected to it is made
 188 the default value returned by `current-input-port',
 189 and the THUNK is called with no arguments.
 190 When the THUNK returns, the port is closed and the previous
 191 default is restored.  Returns the values yielded by THUNK.  If an
 192 escape procedure is used to escape from the continuation of these
 193 procedures, their behavior is implementation dependent."
 194   (call-with-input-file file
 195    (lambda (p) (with-input-from-port p thunk))))
 196
 197 (define (with-output-to-file file thunk)
 198   "THUNK must be a procedure of no arguments, and FILE must be a
 199 string naming a file.  The effect is unspecified if the file already exists.
 200 The file is opened for output, an output port connected to it is made
 201 the default value returned by `current-output-port',
 202 and the THUNK is called with no arguments.
 203 When the THUNK returns, the port is closed and the previous
 204 default is restored.  Returns the values yielded by THUNK.  If an
 205 escape procedure is used to escape from the continuation of these
 206 procedures, their behavior is implementation dependent."
 207   (call-with-output-file file
 208    (lambda (p) (with-output-to-port p thunk))))
 209
 210 (define (with-error-to-file file thunk)
 211   "THUNK must be a procedure of no arguments, and FILE must be a
 212 string naming a file.  The effect is unspecified if the file already exists.
 213 The file is opened for output, an output port connected to it is made
 214 the default value returned by `current-error-port',
 215 and the THUNK is called with no arguments.
 216 When the THUNK returns, the port is closed and the previous
 217 default is restored.  Returns the values yielded by THUNK.  If an
 218 escape procedure is used to escape from the continuation of these
 219 procedures, their behavior is implementation dependent."
 220   (call-with-output-file file
 221    (lambda (p) (with-error-to-port p thunk))))
 222
 223 (define (with-input-from-string string thunk)
 224   "THUNK must be a procedure of no arguments.
 225 The test of STRING  is opened for
 226 input, an input port connected to it is made,
 227 and the THUNK is called with no arguments.
 228 When the THUNK returns, the port is closed.
 229 Returns the values yielded by THUNK.  If an
 230 escape procedure is used to escape from the continuation of these
 231 procedures, their behavior is implementation dependent."
 232   (call-with-input-string string
 233    (lambda (p) (with-input-from-port p thunk))))
 234
 235 (define (with-output-to-string thunk)
 236   "Calls THUNK and returns its output as a string."
 237   (call-with-output-string
 238    (lambda (p) (with-output-to-port p thunk))))
 239
 240 (define (with-error-to-string thunk)
 241   "Calls THUNK and returns its error output as a string."
 242   (call-with-output-string
 243    (lambda (p) (with-error-to-port p thunk))))
 244
 245 (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))