summaryrefslogtreecommitdiff
path: root/ice-9/r4rs.scm
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9/r4rs.scm')
-rw-r--r--ice-9/r4rs.scm149
1 files changed, 149 insertions, 0 deletions
diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm
new file mode 100644
index 000000000..696ba4059
--- /dev/null
+++ b/ice-9/r4rs.scm
@@ -0,0 +1,149 @@
+;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
+;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
+
+;;;; Copyright (C) 1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;;; apply and call-with-current-continuation
+
+;;; These turn syntax, @apply and @call-with-current-continuation,
+;;; into procedures. If someone knows why they have to be syntax to
+;;; begin with, please fix this comment.
+(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
+(define (call-with-current-continuation proc)
+ (@call-with-current-continuation proc))
+
+
+;;;; 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. MSDOS does carraige return - newline
+;; translation if not opened in `b' mode.
+;;
+(define OPEN_READ (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "rb")
+ (else "r")))
+(define OPEN_WRITE (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "wb")
+ (else "w")))
+(define OPEN_BOTH (case (software-type)
+ ((MS-DOS WINDOWS ATARIST) "r+b")
+ (else "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))))
+
+
+;;;; 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)
+
+;;; If we load boot-9.scm, it provides a definition for this which is
+;;; more sophisticated.
+(define read-sharp #f)
+
+(define (load name)
+ (start-stack 'load-stack
+ (primitive-load name #t read-sharp)))