diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 3b84a4fb0..65ccf2787 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +Mon Jul 21 06:45:45 1997 Gary Houston + + * boot-9.scm (dup->port, dup->inport, dup->outport, dup->fdes, + dup, fdes->inport, fdes->outport, port->fdes): new procedures. + (duplicate-port): was a C primitive, now it's here. + (move->fdes): allow the first argument to be a file descriptor. + Return the modified port or file descriptor (was unspecified.) + Fri Jul 11 00:13:43 1997 Jim Blandy Changes to compile under gnu-win32, from Marcus Daniels: diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 7afb0134d..4542f6415 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -766,16 +766,79 @@ (define (open-input-pipe command) (open-pipe command OPEN_READ)) (define (open-output-pipe command) (open-pipe command OPEN_WRITE)) -(define (move->fdes port fd) - (primitive-move->fdes port fd) - (set-port-revealed! port 1) - port) +(define (move->fdes fd/port fd) + (cond ((integer? fd/port) + (primitive-dup2 fd/port fd) + (close fd/port) + fd) + (else + (primitive-move->fdes fd/port fd) + (set-port-revealed! fd/port 1) + fd/port))) (define (release-port-handle port) (let ((revealed (port-revealed port))) (if (> revealed 0) (set-port-revealed! port (- revealed 1))))) +(define (dup->port port/fd mode . maybe-fd) + (let ((port (fdopen (if (pair? maybe-fd) + (primitive-dup2 port/fd (car maybe-fd)) + (primitive-dup port/fd)) + mode))) + (if (pair? maybe-fd) + (set-port-revealed! port 1)) + port)) + +(define (dup->inport port/fd . maybe-fd) + (apply dup->port port/fd "r" maybe-fd)) + +(define (dup->outport port/fd . maybe-fd) + (apply dup->port port/fd "w" maybe-fd)) + +(define (dup->fdes port/fd . maybe-fd) + (if (pair? maybe-fd) + (primitive-dup2 port/fd (car maybe-fd)) + (primitive-dup port/fd))) + +(define (dup port/fd . maybe-fd) + (if (integer? port/fd) + (apply dup->fdes port/fd maybe-fd) + (apply dup->port port/fd (port-mode port/fd) maybe-fd))) + +(define (duplicate-port port modes) + (dup->port port modes)) + +(define (fdes->inport fdes) + (let loop ((rest-ports (fdes->ports fdes))) + (cond ((null? rest-ports) + (let ((result (fdopen fdes "r"))) + (set-port-revealed! result 1) + result)) + ((input-port? (car rest-ports)) + (set-port-revealed! (car rest-ports) + (+ (port-revealed (car rest-ports)) 1)) + (car rest-ports)) + (else + (loop (cdr rest-ports)))))) + +(define (fdes->outport fdes) + (let loop ((rest-ports (fdes->ports fdes))) + (cond ((null? rest-ports) + (let ((result (fdopen fdes "w"))) + (set-port-revealed! result 1) + result)) + ((output-port? (car rest-ports)) + (set-port-revealed! (car rest-ports) + (+ (port-revealed (car rest-ports)) 1)) + (car rest-ports)) + (else + (loop (cdr rest-ports)))))) + +(define (port->fdes port) + (set-port-revealed! port (+ (port-revealed port) 1)) + (fileno port)) + ;;; {Load Paths} ;;; diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d9e6b7be8..193b58b3f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,16 @@ +Mon Jul 21 04:03:42 1997 Gary Houston + + * ioext.h: removed scm_duplicate_port prototype. + + * ioext.c (scm_primitive_dup2): return the new file descriptor + instead of SCM_UNSPECIFIED, since similarity to scm_primitive_dup + is convenient. + (scm_fdopen): bug fix: don't try to make port unbuffered until its + stream has been set. + (scm_duplicate_port): deleted, there's now an implementation in + boot-9.scm. + (scm_primitive_dup2): do nothing if newfd == oldfd. + Sun Jul 20 03:55:49 1997 Gary Houston * filesys.c (scm_close): oops, don't call SCM_INUM twice on the diff --git a/libguile/ioext.c b/libguile/ioext.c index ae2f5903b..04e3fa485 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -233,55 +233,6 @@ scm_freopen (filename, modes, port) return port; } - - -SCM_PROC (s_duplicate_port, "duplicate-port", 2, 0, 0, scm_duplicate_port); - -SCM -scm_duplicate_port (oldpt, modes) - SCM oldpt; - SCM modes; -{ - int oldfd; - int newfd; - FILE *f; - SCM newpt; - SCM_ASSERT (SCM_NIMP (oldpt) && SCM_OPPORTP (oldpt), oldpt, SCM_ARG1, - s_duplicate_port); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, - s_duplicate_port); - - SCM_COERCE_SUBSTR (modes); - SCM_NEWCELL (newpt); - SCM_DEFER_INTS; - oldfd = fileno ((FILE *)SCM_STREAM (oldpt)); - if (oldfd == -1) - scm_syserror (s_duplicate_port); - SCM_SYSCALL (newfd = dup (oldfd)); - if (newfd == -1) - scm_syserror (s_duplicate_port); - f = fdopen (newfd, SCM_ROCHARS (modes)); - if (!f) - { - SCM_SYSCALL (close (newfd)); - scm_syserror (s_duplicate_port); - } - { - struct scm_port_table * pt; - pt = scm_add_to_port_table (newpt); - SCM_SETPTAB_ENTRY (newpt, pt); - SCM_SETCAR (newpt, scm_tc16_fport | scm_mode_bits (SCM_ROCHARS (modes))); - SCM_SETSTREAM (newpt, (SCM)f); - if (SCM_BUF0 & SCM_CAR (newpt)) - scm_setbuf0 (newpt); - SCM_PTAB_ENTRY (newpt)->file_name = SCM_PTAB_ENTRY (oldpt)->file_name; - } - SCM_ALLOW_INTS; - return newpt; -} - - - SCM_PROC (s_redirect_port, "redirect-port", 2, 0, 0, scm_redirect_port); SCM @@ -349,14 +300,19 @@ scm_primitive_dup2 (SCM fd_or_port, SCM fd) scm_syserror (s_primitive_dup2); } - SCM_ASSERT (SCM_INUMP (newfd), newfd, SCM_ARG2, s_primitive_dup2); + SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_dup2); newfd = SCM_INUM (fd); + if (oldfd == newfd) + { + SCM_ALLOW_INTS; + return fd; + } scm_evict_ports (newfd); /* see scsh manual. */ SCM_SYSCALL (rv = dup2 (oldfd, newfd)); if (rv == -1) scm_syserror (s_primitive_dup2); SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; + return fd; } SCM_PROC (s_fileno, "fileno", 1, 0, 0, scm_fileno); @@ -413,9 +369,9 @@ scm_fdopen (fdes, modes) pt = scm_add_to_port_table (port); SCM_SETPTAB_ENTRY (port, pt); SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_ROCHARS (modes))); + SCM_SETSTREAM (port, (SCM)f); if (SCM_BUF0 & SCM_CAR (port)) scm_setbuf0 (port); - SCM_SETSTREAM (port, (SCM)f); SCM_ALLOW_INTS; return port; } diff --git a/libguile/ioext.h b/libguile/ioext.h index 5e8302427..ee5ed86cf 100644 --- a/libguile/ioext.h +++ b/libguile/ioext.h @@ -53,7 +53,6 @@ extern SCM scm_write_line SCM_P ((SCM obj, SCM port)); extern SCM scm_ftell SCM_P ((SCM port)); extern SCM scm_fseek SCM_P ((SCM port, SCM offset, SCM whence)); extern SCM scm_freopen SCM_P ((SCM filename, SCM modes, SCM port)); -extern SCM scm_duplicate_port SCM_P ((SCM oldpt, SCM modes)); extern SCM scm_redirect_port SCM_P ((SCM into_pt, SCM from_pt)); extern SCM scm_primitive_dup (SCM fd_or_port); extern SCM scm_primitive_dup2 (SCM fd_or_port, SCM newfd);