Added SET-CURRENT-INPUT-PORT! and friends.

Rehacked stdio/stdport sync procedures.

scsh/newports.scm

@@ -367,6 +367,15 @@
   (with-error-output-port* port (lambda () body ...)))
 
 
+;;; set-foo-port! procs
+;;; -------------------
+;;; Side-effecting variants of with-current-input-port* and friends.
+
+(define (set-current-input-port!  port) (set-fluid! $current-input-port  port))
+(define (set-current-output-port! port) (set-fluid! $current-output-port port))
+(define (set-error-output-port!   port) (set-fluid! $error-output-port   port))
+
+
 ;;; call-with-foo-file with-foo-to-file
 ;;; -----------------------------------
 

scsh/pty.scm

@@ -26,9 +26,7 @@
 			      (dup->outport tty 1)
 			      (set-port-buffering (dup->outport tty 2)
 						  bufpol/none))
-			   
+			    (with-stdio-ports* thunk))))
-			    ;; No good -- leaves old ones around:
-			    (stdio->stdports thunk))))
 	   (pty-out (dup->outport pty-in)))
 
       (set-port-buffering pty-out bufpol/none)

scsh/scsh-interfaces.scm

@@ -175,6 +175,15 @@
 			      (with-current-output-port :syntax)
 			      with-error-output-port*
 			      (with-error-output-port :syntax)
+			      set-current-input-port!
+			      set-current-output-port!
+			      set-error-output-port!
+
+			      stdports->stdio
+			      stdio->stdports
+			      with-stdio-ports*
+			      (with-stdio-ports :syntax)
+
 			      call/fdes
 			      release-port-handle
 			      port-revealed
@@ -189,8 +198,6 @@
 			      port->list
 			      reduce-port
 			      port->fdes
-			      stdports->stdio
-			      stdio->stdports
 			      read-string
 			      read-string!
 			      read-string/partial
@@ -248,10 +255,12 @@
 	  file-socket?
 	  file-special?
 	  file-not-readable?
-	  file-not-writeable?
+	  file-not-writable?
+	  file-not-writeable?	; Deprecated
 	  file-not-executable?
 	  file-readable?
 	  file-writeable?
+	  file-writable?	; Deprecated
 	  file-executable?
 	  file-not-exists?
 	  file-exists?
@@ -497,7 +506,6 @@
 	  (run/string     :syntax)
 	  (run/sexp       :syntax)
 	  (run/sexps      :syntax)
-	  (run/pty        :syntax)
 
 	  fork/pipe
 	  %fork/pipe
@@ -508,7 +516,6 @@
 	  run/collecting*
 	  run/port+proc*
 	  run/port*
-	  run/pty*
 	  run/file*
 	  run/string*
 	  run/sexp*
@@ -539,7 +546,8 @@
 	  optional-arg optional-arg* parse-optionals
 	  check-arg conjoin disjoin negate compose reverse! call/cc
 	  deprecated-proc
-	  deposit-bit-field))
+	  deposit-bit-field
+	  real->exact-integer))
 
 ;;; semi-standard network magic numbers
 ;;; should be available on all platforms

scsh/scsh.scm

@@ -472,79 +472,6 @@
 (define (run/strings* thunk)
   (close-after (run/port* thunk) port->string-list))
 
-;;; Pseudo terminals
-
-(define (run/pty* thunk)
-  (receive (pty tty)
-	   (pty-open)
-     (let ((proc (fork (lambda ()
-			 (dup->inport  tty 0)
-			 (dup->outport tty 1)
-			 (dup->outport tty 2)
-			 (close tty)
-			 (thunk)))))
-       (values proc pty (dup->outport pty)))))
-
-;; returns an open pty and the name of the corresponding tty
-(define (pty-open)
-  (let ((next-pty (make-pty-generator)))
-    (let loop ()
-	(cond ((next-pty) =>
-	       (lambda (pty-name)
-		 ;; what if we have an error opening tty?
-		 ;; supposedly it's agreed to open pty first
-		 ;; but what does the average unix programer know
-		 ;; unix standards. if it works once, it's fine -bri
-		 (with-errno-handler ((errno packet)
-				      ((errno/io errno/acces)
-				       (loop)))
-                   (let ((pty (open-file pty-name open/read+write)))
-		     (values pty
-			     (open-file (pty->tty pty-name) 
-					open/read+write))))))
-	      (else
-	       (error "pty-open: could not open new pty"))))))
-
-;; The following code two pty functions may in fact be system dependant
-;; if so, we'll move it out to the architecture specific directories 
-;; i can't believe this isnt standard or at least a library routine.
-;; oh wait, sysV has libpt.a with routines like this but they are 
-;; undocumented. welcome to the future -bri 
-
-;;; takes a pty string and makes a new string that is the matching tty
-(define (pty->tty pty)
-  (let ((p-pos 5)			; index of p in pty
-	(tty (string-copy pty)))
-    (string-set!  tty p-pos #\t)
-    tty))
-
-;;; a generator for all possible pty names
-(define (make-pty-generator)
-  (let* ((pattern (string-copy"/dev/ptyLN")) ; L=letter N=number
-	 (len (string-length pattern))
-	 (l-pos (- len 2))
-	 (n-pos (- len 1))
-	 ;; from telnetd source in BSD4.4
-	 (letters "pqrstuvwxyzPQRST")
-	 (numbers "0123456789abcdef")
-	 (l-len (string-length letters))
-	 (n-len (string-length numbers))
-	 (l 0)
-	 (n 0))
-    (string-set! pattern l-pos (string-ref letters l)) ; initialize letter
-    (lambda ()
-      (cond ((= n n-len)
-	     (set! l (+ l 1))
-	     (cond ((>= l l-len) #f)
-		   (else
-		    (string-set! pattern l-pos (string-ref letters l))
-		    (string-set! pattern n-pos (string-ref numbers 0)) 
-		    (set! n 1)
-		    pattern)))
-	    (else
-	     (string-set! pattern n-pos (string-ref numbers n)) ; change number
-	     (set! n (+ n 1))
-	     pattern)))))
 
 ;;; Read characters from PORT until EOF, collect into a string.
 
@@ -621,12 +548,24 @@
 				      (substring buf 0 nread)))) ; last one.
 		 (lp))))))))
 
-(define (stdio->stdports thunk)
+
+;;; Stdio/stdport sync procedures
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stdio->stdports)
+  (set-current-input-port!  (fdes->inport 0))
+  (set-current-output-port! (fdes->inport 1))
+  (set-error-output-port!   (fdes->inport 2)))
+
+(define (with-stdio-ports* thunk)
   (with-current-input-port (fdes->inport 0)
     (with-current-output-port (fdes->outport 1)
       (with-error-output-port (fdes->outport 2)
 	(thunk)))))
 
+(define-simple-syntax (with-stdio-ports body ...)
+  (with-stdio-ports* (lambda () body ...)))
+
 
 (define (stdports->stdio)
   (dup (current-input-port)  0)

scsh/syntax-helpers.scm

@@ -100,9 +100,9 @@
 
 
 (define (transcribe-begin-process-form body rename compare)
-  (let ((%stdio->stdports (rename 'stdio->stdports))
+  (let ((%with-stdio-ports* (rename 'with-stdio-ports*))
 	(%lambda          (rename 'lambda)))
-    `(,%stdio->stdports (,%lambda () . ,body))))
+    `(,%with-stdio-ports* (,%lambda () . ,body))))
 
 
 (define (transcribe-simple-pipeline pfs rename compare)

scsh/syscalls.scm

@@ -401,11 +401,11 @@
 
 (define (set-file-times/errno path . maybe-times)
   (if (pair? maybe-times)
-      (let ((access-time (car maybe-times))
+      (let* ((access-time (real->exact-integer (car maybe-times)))
-	    (mod-time (if (pair? (cddr maybe-times))
+	     (mod-time (if (pair? (cddr maybe-times))
-			  (error "Too many arguments to set-file-times/errno"
+			   (error "Too many arguments to set-file-times/errno"
-				 (cons path maybe-times))
+				  (cons path maybe-times))
-			  (cadr maybe-times))))
+			   (real->exact-integer (cadr maybe-times)))))
 	(%utime/errno path (hi8 access-time) (lo24 access-time)
 		           (hi8 mod-time)    (lo24 mod-time)))
       (%utime-now/errno path)))