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