*** empty log message ***

[bpt/guile.git] / ice-9 / r4rs.scm

;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
;;;; Jim Blandy <jimb@cyclic.com> --- October 1996

;;;; 	Copyright (C) 1996, 1997, 1998 Free Software Foundation, Inc.
;;;; 
;;;; This program 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, or (at your option)
;;;; any later version.
;;;; 
;;;; This program 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 this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA

\f
;;;; apply and call-with-current-continuation

;;; We want these to be tail-recursive, so instead of using primitive
;;; procedures, we define them as closures in terms of the primitive
;;; macros @apply and @call-with-current-continuation.
(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
(set-procedure-property! apply 'name 'apply)
(define (call-with-current-continuation proc)
  (@call-with-current-continuation proc))

\f
;;;; Basic Port Code

;;; Specifically, the parts of the low-level port code that are written in 
;;; Scheme rather than C.
;;;
;;; WARNING: the parts of this interface that refer to file ports
;;; are going away.   It would be gone already except that it is used
;;; "internally" in a few places.


;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
;;; proper mode to open files in.
;;;
;;; If we want to support systems that do CRLF->LF translation, like
;;; Windows, then we should have a symbol in scmconfig.h made visible
;;; to the Scheme level that we can test here, and autoconf magic to
;;; #define it when appropriate.  Windows will probably just have a
;;; hand-generated scmconfig.h file.
(define OPEN_READ "r")
(define OPEN_WRITE "w")
(define OPEN_BOTH "r+")

(define *null-device* "/dev/null")

(define (open-input-file str)
  (open-file str OPEN_READ))

(define (open-output-file str)
  (open-file str OPEN_WRITE))

(define (open-io-file str) (open-file str OPEN_BOTH))
(define close-input-port close-port)
(define close-output-port close-port)
(define close-io-port close-port)

(define (call-with-input-file str proc)
  (let* ((file (open-input-file str))
	 (ans (proc file)))
    (close-input-port file)
    ans))

(define (call-with-output-file str proc)
  (let* ((file (open-output-file str))
	 (ans (proc file)))
    (close-output-port file)
    ans))

(define (with-input-from-port port thunk)
  (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
    (dynamic-wind swaports thunk swaports)))

(define (with-output-to-port port thunk)
  (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
    (dynamic-wind swaports thunk swaports)))

(define (with-error-to-port port thunk)
  (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
    (dynamic-wind swaports thunk swaports)))

(define (with-input-from-file file thunk)
  (let* ((nport (open-input-file file))
	 (ans (with-input-from-port nport thunk)))
    (close-port nport)
    ans))

(define (with-output-to-file file thunk)
  (let* ((nport (open-output-file file))
	 (ans (with-output-to-port nport thunk)))
    (close-port nport)
    ans))

(define (with-error-to-file file thunk)
  (let* ((nport (open-output-file file))
	 (ans (with-error-to-port nport thunk)))
    (close-port nport)
    ans))

(define (with-input-from-string string thunk)
  (call-with-input-string string
   (lambda (p) (with-input-from-port p thunk))))

(define (with-output-to-string thunk)
  (call-with-output-string
   (lambda (p) (with-output-to-port p thunk))))

(define (with-error-to-string thunk)
  (call-with-output-string
   (lambda (p) (with-error-to-port p thunk))))

(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))

\f
;;;; Loading

(if (not (defined? '%load-verbosely))
    (define %load-verbosely #f))
(define (assert-load-verbosity v) (set! %load-verbosely v))

(define (%load-announce file)
  (if %load-verbosely
      (with-output-to-port (current-error-port)
	(lambda ()
	  (display ";;; ")
	  (display "loading ")
	  (display file)
	  (newline)
	  (force-output)))))

(set! %load-hook %load-announce)

(define (load name)
  (start-stack 'load-stack
	       (primitive-load name)))