~ chicken-core (chicken-5) 586d998c928abb4a7c4ca964ecedc80a58f81ed0
commit 586d998c928abb4a7c4ca964ecedc80a58f81ed0
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Sep 8 11:29:32 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Sep 8 11:29:32 2011 +0200
moved some fd-related stuff into posix-common, disabled check for failed port->fileno in port tests
diff --git a/posix-common.scm b/posix-common.scm
index 6ce6443c..3a8d5cae 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -227,6 +227,66 @@ EOF
(eq? 'directory (file-type file #f #f)))
+;;; Using file-descriptors:
+
+(define-foreign-variable _stdin_fileno int "STDIN_FILENO")
+(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")
+(define-foreign-variable _stderr_fileno int "STDERR_FILENO")
+
+(define fileno/stdin _stdin_fileno)
+(define fileno/stdout _stdout_fileno)
+(define fileno/stderr _stderr_fileno)
+
+(let ()
+ (define (mode inp m loc)
+ (##sys#make-c-string
+ (cond [(pair? m)
+ (let ([m (car m)])
+ (case m
+ [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
+ [else (##sys#error "invalid mode argument" m)] ) ) ]
+ [inp "r"]
+ [else "w"] )
+ loc) )
+ (define (check loc fd inp r)
+ (if (##sys#null-pointer? r)
+ (posix-error #:file-error loc "cannot open file" fd)
+ (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
+ (##core#inline "C_set_file_ptr" port r)
+ port) ) )
+ (set! open-input-file*
+ (lambda (fd . m)
+ (##sys#check-exact fd 'open-input-file*)
+ (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*))) ) )
+ (set! open-output-file*
+ (lambda (fd . m)
+ (##sys#check-exact fd 'open-output-file*)
+ (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) ) ) ) )
+
+(define port->fileno
+ (lambda (port)
+ (##sys#check-port port 'port->fileno)
+ (cond [(eq? 'socket (##sys#slot port 7)) (##sys#tcp-port->fileno port)]
+ [(not (zero? (##sys#peek-unsigned-integer port 0)))
+ (let ([fd (##core#inline "C_C_fileno" port)])
+ (when (fx< fd 0)
+ (posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
+ fd) ]
+ [else (posix-error #:type-error 'port->fileno "port has no attached file" port)] ) ) )
+
+(define duplicate-fileno
+ (lambda (old . new)
+ (##sys#check-exact old duplicate-fileno)
+ (let ([fd (if (null? new)
+ (##core#inline "C_dup" old)
+ (let ([n (car new)])
+ (##sys#check-exact n 'duplicate-fileno)
+ (##core#inline "C_dup2" old n) ) ) ] )
+ (when (fx< fd 0)
+ (posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )
+ fd) ) )
+
+
;;; Set or get current directory:
(define (current-directory #!optional dir)
diff --git a/posixunix.scm b/posixunix.scm
index 3d1e0da6..91f6101a 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1292,65 +1292,6 @@ EOF
(posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )
-;;; Using file-descriptors:
-
-(define-foreign-variable _stdin_fileno int "STDIN_FILENO")
-(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")
-(define-foreign-variable _stderr_fileno int "STDERR_FILENO")
-
-(define fileno/stdin _stdin_fileno)
-(define fileno/stdout _stdout_fileno)
-(define fileno/stderr _stderr_fileno)
-
-(let ()
- (define (mode inp m loc)
- (##sys#make-c-string
- (cond [(pair? m)
- (let ([m (car m)])
- (case m
- [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
- [else (##sys#error "invalid mode argument" m)] ) ) ]
- [inp "r"]
- [else "w"] )
- loc) )
- (define (check loc fd inp r)
- (if (##sys#null-pointer? r)
- (posix-error #:file-error loc "cannot open file" fd)
- (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
- (##core#inline "C_set_file_ptr" port r)
- port) ) )
- (set! open-input-file*
- (lambda (fd . m)
- (##sys#check-exact fd 'open-input-file*)
- (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*))) ) )
- (set! open-output-file*
- (lambda (fd . m)
- (##sys#check-exact fd 'open-output-file*)
- (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) ) ) ) )
-
-(define port->fileno
- (lambda (port)
- (##sys#check-port port 'port->fileno)
- (cond [(eq? 'socket (##sys#slot port 7)) (##sys#tcp-port->fileno port)]
- [(not (zero? (##sys#peek-unsigned-integer port 0)))
- (let ([fd (##core#inline "C_C_fileno" port)])
- (when (fx< fd 0)
- (posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
- fd) ]
- [else (posix-error #:type-error 'port->fileno "port has no attached file" port)] ) ) )
-
-(define duplicate-fileno
- (lambda (old . new)
- (##sys#check-exact old duplicate-fileno)
- (let ([fd (if (null? new)
- (##core#inline "C_dup" old)
- (let ([n (car new)])
- (##sys#check-exact n 'duplicate-fileno)
- (##core#inline "C_dup2" old n) ) ) ] )
- (when (fx< fd 0)
- (posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )
- fd) ) )
-
(define ##sys#custom-input-port
(lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f))
(when nonblocking? (##sys#file-nonblocking! fd) )
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 1c445a03..f162edb7 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -139,7 +139,9 @@ EOF
(print "\n\nProcedures check on output ports being closed\n")
-(call-with-output-file "/dev/null"
+(with-output-to-file "empty-file" void)
+
+(call-with-output-file "empty-file"
(lambda (out)
(close-output-port out)
(check (write '(foo) out))
@@ -147,42 +149,49 @@ EOF
(check "print-call-chain" (begin (print-call-chain out) (void)))
(check (print-error-message (make-property-condition 'exn 'message "foo") out))
(check "print" (with-output-to-port out
- (lambda () (print "foo"))))
+ (lambda () (print "foo"))))
(check "print*" (with-output-to-port out
- (lambda () (print* "foo"))))
+ (lambda () (print* "foo"))))
(check (display "foo" out))
- (check (terminal-port? out)) ; Calls isatty() on C_SCHEME_FALSE?
+ (check (terminal-port? out)) ; Calls isatty() on C_SCHEME_FALSE?
(check (newline out))
(check (write-char #\x out))
(check (write-line "foo" out))
(check (write-u8vector '#u8(1 2 3) out))
- (check (port->fileno out))
+ ;;(check (port->fileno in))
(check (flush-output out))
- (check (file-test-lock out))
- (check (file-lock out))
- (check (file-lock/blocking out))
+
+ #+(not windows)
+ (begin
+ (check (file-test-lock out))
+ (check (file-lock out))
+ (check (file-lock/blocking out)))
+
(check (write-byte 120 out))
(check (write-string "foo" #f out))))
(print "\n\nProcedures check on input ports being closed\n")
-(call-with-input-file "/dev/zero"
+(call-with-input-file "empty-file"
(lambda (in)
(close-input-port in)
(check (read in))
(check (read-char in))
(check (char-ready? in))
(check (peek-char in))
- (check (port->fileno in))
- (check (terminal-port? in)) ; Calls isatty() on C_SCHEME_FALSE?
+ ;;(check (port->fileno in))
+ (check (terminal-port? in)) ; Calls isatty() on C_SCHEME_FALSE?
(check (read-line in 5))
(check (read-u8vector 5 in))
(check "read-u8vector!" (let ((dest (make-u8vector 5)))
(read-u8vector! 5 dest in)))
- (check (file-test-lock in))
- (check (file-lock in))
- (check (file-lock/blocking in))
+ #+(not windows)
+ (begin
+ (check (file-test-lock in))
+ (check (file-lock in))
+ (check (file-lock/blocking in)))
+
(check (read-byte in))
(check (read-token (constantly #t) in))
(check (read-string 10 in))
(check "read-string!" (let ((buf (make-string 10)))
- (read-string! 10 buf in) buf))))
\ No newline at end of file
+ (read-string! 10 buf in) buf))))
Trap