File: port.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (80 lines) | stat: -rw-r--r-- 2,265 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

; Current input and output ports.

(define $current-input-port  (make-fluid #f))
(define $current-output-port (make-fluid #f))
(define $error-output-port   (make-fluid #f))

(define (current-input-port)
  (fluid $current-input-port))

(define (current-output-port)
  (fluid $current-output-port))

(define (error-output-port)
  (fluid $error-output-port))

(define (with-initial-ports in out thunk)
  (let-fluids $current-input-port in
	      $current-output-port out
	      $error-output-port out
    thunk))


; File openers with unwind protection

(define (call-with-mumble-file open close)
  (lambda (string proc)
    (let ((port #f))
      (dynamic-wind (lambda ()
		      (if port
			  (warn "throwing back into a call-with-...put-file"
				string)
			  (set! port (open string))))
		    (lambda () (proc port))
		    (lambda ()
		      (if port
			  (close port)))))))

(define call-with-input-file
  (call-with-mumble-file open-input-file close-input-port))

(define call-with-output-file
  (call-with-mumble-file open-output-file close-output-port))

;(define (call-with-input-file string proc)
;  (let* ((port (open-input-file string))
;         (result (proc port)))
;    (close-input-port port)
;    result))
;
;(define (call-with-output-file string proc)
;  (let* ((port (open-output-file string))
;         (result (proc port)))
;    (close-output-port port)
;    result))

(define (with-input-from-file string thunk)
  (call-with-input-file string
    (lambda (port)
      (let-fluid $current-input-port port thunk))))

(define (with-output-to-file string thunk)
  (call-with-output-file string
    (lambda (port)
      (let-fluid $current-output-port port thunk))))

(define (newline . port-option)
  (write-char #\newline (output-port-option port-option)))


(define (output-port-option port-option)
  (cond ((null? port-option) (current-output-port))
	((null? (cdr port-option)) (car port-option))
	(else (error "write-mumble: too many arguments" port-option))))

(define (input-port-option port-option)
  (cond ((null? port-option) (current-input-port))
	((null? (cdr port-option)) (car port-option))
	(else (error "read-mumble: too many arguments" port-option))))