guile18/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 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 2.1 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 \f
  21 ;;;; apply and call-with-current-continuation
  22
  23 ;;; We want these to be tail-recursive, so instead of using primitive
  24 ;;; procedures, we define them as closures in terms of the primitive
  25 ;;; macros @apply and @call-with-current-continuation.
  26 (set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
  27 (set-procedure-property! apply 'name 'apply)
  28 (define (call-with-current-continuation proc)
  29   (@call-with-current-continuation proc))
  30 (define (call-with-values producer consumer)
  31   (@call-with-values producer consumer))
  32
  33 \f
  34 ;;;; Basic Port Code
  35
  36 ;;; Specifically, the parts of the low-level port code that are written in
  37 ;;; Scheme rather than C.
  38 ;;;
  39 ;;; WARNING: the parts of this interface that refer to file ports
  40 ;;; are going away.   It would be gone already except that it is used
  41 ;;; "internally" in a few places.
  42
  43
  44 ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
  45 ;;; proper mode to open files in.
  46 ;;;
  47 ;;; If we want to support systems that do CRLF->LF translation, like
  48 ;;; Windows, then we should have a symbol in scmconfig.h made visible
  49 ;;; to the Scheme level that we can test here, and autoconf magic to
  50 ;;; #define it when appropriate.  Windows will probably just have a
  51 ;;; hand-generated scmconfig.h file.
  52 (define OPEN_READ "r")
  53 (define OPEN_WRITE "w")
  54 (define OPEN_BOTH "r+")
  55
  56 (define *null-device* "/dev/null")
  57
  58 (define (open-input-file str)
  59   "Takes a string naming an existing file and returns an input port
  60 capable of delivering characters from the file.  If the file
  61 cannot be opened, an error is signalled."
  62   (open-file str OPEN_READ))
  63
  64 (define (open-output-file str)
  65   "Takes a string naming an output file to be created and returns an
  66 output port capable of writing characters to a new file by that
  67 name.  If the file cannot be opened, an error is signalled.  If a
  68 file with the given name already exists, the effect is unspecified."
  69   (open-file str OPEN_WRITE))
  70
  71 (define (open-io-file str)
  72   "Open file with name STR for both input and output."
  73   (open-file str OPEN_BOTH))
  74
  75 (define close-io-port close-port)
  76
  77 (define (call-with-input-file str proc)
  78   "PROC should be a procedure of one argument, and STR should be a
  79 string naming a file.  The file must
  80 already exist. These procedures call PROC
  81 with one argument: the port obtained by opening the named file for
  82 input or output.  If the file cannot be opened, an error is
  83 signalled.  If the procedure returns, then the port is closed
  84 automatically and the value yielded by the procedure is returned.
  85 If the procedure does not return, then the port will not be closed
  86 automatically unless it is possible to prove that the port will
  87 never again be used for a read or write operation."
  88   (let* ((file (open-input-file str))
  89          (ans (proc file)))
  90     (close-input-port file)
  91     ans))
  92
  93 (define (call-with-output-file str proc)
  94   "PROC should be a procedure of one argument, and STR should be a
  95 string naming a file.  The behaviour is unspecified if the file
  96 already exists. These procedures call PROC
  97 with one argument: the port obtained by opening the named file for
  98 input or output.  If the file cannot be opened, an error is
  99 signalled.  If the procedure returns, then the port is closed
 100 automatically and the value yielded by the procedure is returned.
 101 If the procedure does not return, then the port will not be closed
 102 automatically unless it is possible to prove that the port will
 103 never again be used for a read or write operation."
 104   (let* ((file (open-output-file str))
 105          (ans (proc file)))
 106     (close-output-port file)
 107     ans))
 108
 109 (define (with-input-from-port port thunk)
 110   (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
 111     (dynamic-wind swaports thunk swaports)))
 112
 113 (define (with-output-to-port port thunk)
 114   (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
 115     (dynamic-wind swaports thunk swaports)))
 116
 117 (define (with-error-to-port port thunk)
 118   (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
 119     (dynamic-wind swaports thunk swaports)))
 120
 121 (define (with-input-from-file file thunk)
 122   "THUNK must be a procedure of no arguments, and FILE must be a
 123 string naming a file.  The file must already exist. The file is opened for
 124 input, an input port connected to it is made
 125 the default value returned by `current-input-port',
 126 and the THUNK is called with no arguments.
 127 When the THUNK returns, the port is closed and the previous
 128 default is restored.  Returns the value yielded by THUNK.  If an
 129 escape procedure is used to escape from the continuation of these
 130 procedures, their behavior is implementation dependent."
 131   (let* ((nport (open-input-file file))
 132          (ans (with-input-from-port nport thunk)))
 133     (close-port nport)
 134     ans))
 135
 136 (define (with-output-to-file file thunk)
 137   "THUNK must be a procedure of no arguments, and FILE must be a
 138 string naming a file.  The effect is unspecified if the file already exists.
 139 The file is opened for output, an output port connected to it is made
 140 the default value returned by `current-output-port',
 141 and the THUNK is called with no arguments.
 142 When the THUNK returns, the port is closed and the previous
 143 default is restored.  Returns the value yielded by THUNK.  If an
 144 escape procedure is used to escape from the continuation of these
 145 procedures, their behavior is implementation dependent."
 146   (let* ((nport (open-output-file file))
 147          (ans (with-output-to-port nport thunk)))
 148     (close-port nport)
 149     ans))
 150
 151 (define (with-error-to-file file thunk)
 152   "THUNK must be a procedure of no arguments, and FILE must be a
 153 string naming a file.  The effect is unspecified if the file already exists.
 154 The file is opened for output, an output port connected to it is made
 155 the default value returned by `current-error-port',
 156 and the THUNK is called with no arguments.
 157 When the THUNK returns, the port is closed and the previous
 158 default is restored.  Returns the value yielded by THUNK.  If an
 159 escape procedure is used to escape from the continuation of these
 160 procedures, their behavior is implementation dependent."
 161   (let* ((nport (open-output-file file))
 162          (ans (with-error-to-port nport thunk)))
 163     (close-port nport)
 164     ans))
 165
 166 (define (with-input-from-string string thunk)
 167   "THUNK must be a procedure of no arguments.
 168 The test of STRING  is opened for
 169 input, an input port connected to it is made,
 170 and the THUNK is called with no arguments.
 171 When the THUNK returns, the port is closed.
 172 Returns the value yielded by THUNK.  If an
 173 escape procedure is used to escape from the continuation of these
 174 procedures, their behavior is implementation dependent."
 175   (call-with-input-string string
 176    (lambda (p) (with-input-from-port p thunk))))
 177
 178 (define (with-output-to-string thunk)
 179   "Calls THUNK and returns its output as a string."
 180   (call-with-output-string
 181    (lambda (p) (with-output-to-port p thunk))))
 182
 183 (define (with-error-to-string thunk)
 184   "Calls THUNK and returns its error output as a string."
 185   (call-with-output-string
 186    (lambda (p) (with-error-to-port p thunk))))
 187
 188 (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
 189
 190 \f
 191 ;;;; Loading
 192
 193 (if (not (defined? '%load-verbosely))
 194     (define %load-verbosely #f))
 195 (define (assert-load-verbosity v) (set! %load-verbosely v))
 196
 197 (define (%load-announce file)
 198   (if %load-verbosely
 199       (with-output-to-port (current-error-port)
 200         (lambda ()
 201           (display ";;; ")
 202           (display "loading ")
 203           (display file)
 204           (newline)
 205           (force-output)))))
 206
 207 (set! %load-hook %load-announce)
 208
 209 (define (load name . reader)
 210   (with-fluid* current-reader (and (pair? reader) (car reader))
 211     (lambda ()
 212       (start-stack 'load-stack
 213                    (primitive-load name)))))