home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / r4rs.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  8.4 KB  |  214 lines
  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.  
  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.  
  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.  
  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)))))
  214.