~ chicken-core (chicken-5) f3360f5f5f1b21545baf0de8aa983eb7b281e57c
commit f3360f5f5f1b21545baf0de8aa983eb7b281e57c
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Tue Jul 18 21:46:38 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jul 19 21:06:56 2017 +1200
Move set-buffering-mode! from posix{unix,win}.scm to port.scm
There was no real reason for having the two implementations separated in
Windows- and UNIX-specific POSIX files, so this just moves the
definition. To avoid another ugly #define block, the ##core#inline is
replaced with a simpler foreign-lambda*.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/port.scm b/port.scm
index 3964ed5a..b3169cdb 100644
--- a/port.scm
+++ b/port.scm
@@ -48,6 +48,7 @@
make-bidirectional-port
make-broadcast-port
make-concatenated-port
+ set-buffering-mode!
with-error-to-port
with-input-from-port
with-input-from-string
@@ -56,10 +57,32 @@
with-error-to-string)
(import scheme chicken)
-(import chicken.io)
+(import chicken.foreign
+ chicken.io)
(include "common-declarations.scm")
+(define-foreign-variable _iofbf int "_IOFBF")
+(define-foreign-variable _iolbf int "_IOLBF")
+(define-foreign-variable _ionbf int "_IONBF")
+(define-foreign-variable _bufsiz int "BUFSIZ")
+
+(define (set-buffering-mode! port mode . size)
+ (##sys#check-port port 'set-buffering-mode!)
+ (let ((size (if (pair? size) (car size) _bufsiz))
+ (mode (case mode
+ ((#:full) _iofbf)
+ ((#:line) _iolbf)
+ ((#:none) _ionbf)
+ (else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)))))
+ (##sys#check-fixnum size 'set-buffering-mode!)
+ (when (fx< (if (eq? 'stream (##sys#slot port 7))
+ ((foreign-lambda* int ((scheme-object p) (int m) (int s))
+ "C_return(setvbuf(C_port_file(p), NULL, m, s));")
+ port mode size)
+ -1)
+ 0)
+ (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size))))
;;;; Port-mapping (found in Gauche):
diff --git a/posix.scm b/posix.scm
index d4815ff7..44cf77b0 100644
--- a/posix.scm
+++ b/posix.scm
@@ -68,8 +68,8 @@
process-group-id process-run process-signal process-sleep
process-spawn process-wait read-symbolic-link regular-file?
seconds->local-time seconds->string seconds->utc-time seek/cur
- seek/end seek/set set-alarm! set-buffering-mode!
- set-environment-variable! set-file-group! set-file-owner!
+ seek/end seek/set
+ set-alarm! set-environment-variable! set-file-group! set-file-owner!
set-file-permissions! set-file-position! set-file-times!
set-root-directory! set-signal-handler! set-signal-mask!
signal-handler signal-mask signal-mask! signal-masked? signal-unmask!
diff --git a/posixunix.scm b/posixunix.scm
index 63f0f891..9203c03a 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -150,7 +150,6 @@ static C_TLS struct stat C_statbuf;
#define C_ftruncate(f, n) C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))
#define C_uname C_fix(uname(&C_utsname))
#define C_alarm alarm
-#define C_setvbuf(p, m, s) C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
#define C_test_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
#define C_close(fd) C_fix(close(C_unfix(fd)))
#define C_umask(m) C_fix(umask(C_unfix(m)))
@@ -1286,27 +1285,6 @@ static C_word C_i_fifo_p(C_word name)
(define set-alarm! (foreign-lambda int "C_alarm" int))
-(define-foreign-variable _iofbf int "_IOFBF")
-(define-foreign-variable _iolbf int "_IOLBF")
-(define-foreign-variable _ionbf int "_IONBF")
-(define-foreign-variable _bufsiz int "BUFSIZ")
-
-(define set-buffering-mode!
- (lambda (port mode . size)
- (##sys#check-port port 'set-buffering-mode!)
- (let ([size (if (pair? size) (car size) _bufsiz)]
- [mode (case mode
- [(#:full) _iofbf]
- [(#:line) _iolbf]
- [(#:none) _ionbf]
- [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
- (##sys#check-fixnum size 'set-buffering-mode!)
- (when (fx< (if (eq? 'stream (##sys#slot port 7))
- (##core#inline "C_setvbuf" port mode size)
- -1)
- 0)
- (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
-
(define (terminal-port? port)
(##sys#check-open-port port 'terminal-port?)
(let ([fp (##sys#peek-unsigned-integer port 0)])
diff --git a/posixwin.scm b/posixwin.scm
index b6c6ff0b..2e0819ac 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -202,7 +202,6 @@ readdir(DIR * dir)
#define close_pipe(p) C_fix(_pclose(C_port_file(p)))
#define C_chmod(fn, m) C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
-#define C_setvbuf(p, m, s) C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
#define C_test_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
#define C_pipe(d, m) C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
#define C_close(fd) C_fix(close(C_unfix(fd)))
@@ -1053,27 +1052,6 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(values 0 0)
(##sys#error 'terminal-size "port is not connected to a terminal" port)))
-(define-foreign-variable _iofbf int "_IOFBF")
-(define-foreign-variable _iolbf int "_IOLBF")
-(define-foreign-variable _ionbf int "_IONBF")
-(define-foreign-variable _bufsiz int "BUFSIZ")
-
-(define set-buffering-mode!
- (lambda (port mode . size)
- (##sys#check-open-port port 'set-buffering-mode!)
- (let ([size (if (pair? size) (car size) _bufsiz)]
- [mode (case mode
- [(###full) _iofbf]
- [(###line) _iolbf]
- [(###none) _ionbf]
- [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
- (##sys#check-fixnum size 'set-buffering-mode!)
- (when (fx< (if (eq? 'stream (##sys#slot port 7))
- (##core#inline "C_setvbuf" port mode size)
- -1)
- 0)
- (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
-
;;; Process handling:
(define-foreign-variable _p_overlay int "P_OVERLAY")
diff --git a/types.db b/types.db
index 98d10e08..9f6d4015 100644
--- a/types.db
+++ b/types.db
@@ -1863,6 +1863,7 @@
(chicken.port#make-bidirectional-port (#(procedure #:clean #:enforce) chicken.port#make-bidirectional-port (input-port output-port) (refine (input output) port)))
(chicken.port#make-broadcast-port (#(procedure #:clean #:enforce) chicken.port#make-broadcast-port (#!rest output-port) output-port))
(chicken.port#make-concatenated-port (#(procedure #:clean #:enforce) chicken.port#make-concatenated-port (port #!rest input-port) input-port))
+(chicken.port#set-buffering-mode! (#(procedure #:clean #:enforce) chicken.port#set-buffering-mode! (port symbol #!optional fixnum) undefined))
(chicken.port#with-error-to-port (#(procedure #:enforce) chicken.port#with-error-to-port (output-port (procedure () . *)) . *))
(chicken.port#with-input-from-port (#(procedure #:enforce) chicken.port#with-input-from-port (input-port (procedure () . *)) . *))
(chicken.port#with-input-from-string (#(procedure #:enforce) chicken.port#with-input-from-string (string (procedure () . *)) . *))
@@ -2040,7 +2041,6 @@
(chicken.posix#seek/end fixnum)
(chicken.posix#seek/set fixnum)
(chicken.posix#set-alarm! (#(procedure #:clean #:enforce) chicken.posix#set-alarm! (integer) integer))
-(chicken.posix#set-buffering-mode! (#(procedure #:clean #:enforce) chicken.posix#set-buffering-mode! (port symbol #!optional fixnum) undefined))
(chicken.posix#set-file-group! (#(procedure #:clean #:enforce) chicken.posix#set-file-group! ((or string fixnum port) fixnum) undefined))
(chicken.posix#set-file-owner! (#(procedure #:clean #:enforce) chicken.posix#set-file-owner! ((or string fixnum port) fixnum) undefined))
(chicken.posix#set-file-permissions! (#(procedure #:clean #:enforce) chicken.posix#set-file-permissions! ((or string fixnum port) fixnum) undefined))
Trap