[[project @ 1997-08-23 19:20:19 by ghouston]
ghouston**19970823192029
 Ignore-this: 3af1d0859f402b175c20b6952229e94c
 * scsh.scm (exec-path-search, exec/env, exec-path/env, exec-path,
 exec, fork, %fork, really-fork): defined.
 (fork/pipe, %fork/pipe, really-fork/pipe, %fork/pipe+, fork/pipe+,
 really-fork/pipe+, tail-pipe, tail-pipe+, pipe*): defined.
 * init.scm (set-batch-mode?!, batch-mode?): dummy definitions.
 * Makefile.am, init.scm: add bitwise.scm.
 * bitwise.scm: new file from scsh-0.5.1/alt/.
 (biwise-not, bitwise-and, bitwise-or, bitwise-ior, bitwise-xor):
 moved from init.scm.
 (count-bits): shift -1, not 1.  Commented out, seems unused.
 * scsh-condition.scm (errno-error, with-errno-handler): modified
 to use Guile primitives.
 Don't define syscall-error condition type.
 * syscalls.scm (errno-msg): defined.
 * errno.scm: include all errnos from cpp_err_symbols.in (libguile).
] addfile ./bitwise.scm
hunk ./ChangeLog 1
+Sat Aug 23 19:17:19 1997  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* scsh.scm (exec-path-search, exec/env, exec-path/env, exec-path, 
+	exec, fork, %fork, really-fork): defined.
+	(fork/pipe, %fork/pipe, really-fork/pipe, %fork/pipe+, fork/pipe+,
+	really-fork/pipe+, tail-pipe, tail-pipe+, pipe*): defined.
+	* init.scm (set-batch-mode?!, batch-mode?): dummy definitions.
+	* Makefile.am, init.scm: add bitwise.scm.
+	* bitwise.scm: new file from scsh-0.5.1/alt/.
+	(biwise-not, bitwise-and, bitwise-or, bitwise-ior, bitwise-xor):
+	moved from init.scm.
+	(count-bits): shift -1, not 1.  Commented out, seems unused.
+	* scsh-condition.scm (errno-error, with-errno-handler): modified
+	to use Guile primitives.
+	Don't define syscall-error condition type.
+	* syscalls.scm (errno-msg): defined.
+	* errno.scm: include all errnos from cpp_err_symbols.in (libguile).
+
hunk ./INCOMPAT 32
-affected: read-delimited read-delimited! pipe sleep (probably
+affected: read-delimited read-delimited! pipe sleep exit (probably
hunk ./Makefile.am 6
-scsh_DATA = char-set.scm condition.scm \
+scsh_DATA = bitwise.scm char-set.scm condition.scm \
hunk ./Makefile.in 64
-scsh_DATA = char-set.scm condition.scm \
+scsh_DATA = bitwise.scm char-set.scm condition.scm \
hunk ./bitwise.scm 1
+; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
+
+; modified for Guile.
+
+; Bitwise operators written in vanilla Scheme.
+; Written for clarity and simplicity, not for speed.
+
+; No need to use these in Scheme 48 since Scheme 48's virtual machine
+; provides fast machine-level implementations.
+
+;; use Guile primitives.
+(define (bitwise-not a) (lognot a))
+(define (bitwise-and a b) (logand a b))
+(define (bitwise-ior a b) (logior a b))
+(define (bitwise-xor a b) (logxor a b))
+
+;;(define (bitwise-not i)
+;;  (- -1 i))
+
+;;(define (bitwise-and x y)
+;;  (cond ((= x 0) 0)
+;;	((= x -1) y)
+;;	(else
+;;	 (+ (* (bitwise-and (arithmetic-shift x -1)
+;;			    (arithmetic-shift y -1))
+;;	       2)
+;;	    (* (modulo x 2) (modulo y 2))))))
+
+;;(define (bitwise-ior x y)
+;;  (bitwise-not (bitwise-and (bitwise-not x)
+;;			    (bitwise-not y))))
+
+;;(define (bitwise-xor x y)
+;;  (bitwise-and (bitwise-not (bitwise-and x y))
+;;	       (bitwise-ior x y)))
+
+(define (bitwise-eqv x y)
+  (bitwise-not (bitwise-xor x y)))
+
+
+(define (arithmetic-shift n m)
+  (inexact->exact (floor (* n (expt 2 m)))))
+
+
+;;(define (count-bits x)		; Count 1's in the positive 2's comp rep
+;;  (let ((x (if (< x 0) (bitwise-not x) x)))
+;;    (do ((x x (arithmetic-shift x -1))
+;;	 (result 0 (+ result (modulo x 2))))
+;;	((= x 0) result))))
+
+;(define (integer-length integer) ...) ;?
hunk ./errno.scm 13
-(maybe-define-eno EPERM)
-(maybe-define-eno EINTR)
-(maybe-define-eno EAGAIN)
-(maybe-define-eno EWOULDBLOCK)
+(maybe-define-eno E2BIG)
hunk ./errno.scm 15
-(maybe-define-eno ENOENT)
-(maybe-define-eno ENOTDIR)
+(maybe-define-eno EADDRINUSE)
+(maybe-define-eno EADDRNOTAVAIL)
+(maybe-define-eno EADV)
+(maybe-define-eno EAFNOSUPPORT)
+(maybe-define-eno EAGAIN)
+(maybe-define-eno EALREADY)
+(maybe-define-eno EBADE)
+(maybe-define-eno EBADF)
+(maybe-define-eno EBADFD)
+(maybe-define-eno EBADMSG)
+(maybe-define-eno EBADR)
+(maybe-define-eno EBADRQC)
+(maybe-define-eno EBADSLT)
+(maybe-define-eno EBFONT)
+(maybe-define-eno EBUSY)
hunk ./errno.scm 31
+(maybe-define-eno ECHRNG)
+(maybe-define-eno ECOMM)
+(maybe-define-eno ECONNABORTED)
+(maybe-define-eno ECONNREFUSED)
+(maybe-define-eno ECONNRESET)
+(maybe-define-eno EDEADLK)
+(maybe-define-eno EDEADLOCK)
+(maybe-define-eno EDESTADDRREQ)
+(maybe-define-eno EDOM)
+(maybe-define-eno EDOTDOT)
+(maybe-define-eno EDQUOT)
hunk ./errno.scm 43
-(maybe-define-eno EBADF)
+(maybe-define-eno EFAULT)
+(maybe-define-eno EFBIG)
+(maybe-define-eno EHOSTDOWN)
+(maybe-define-eno EHOSTUNREACH)
+(maybe-define-eno EIDRM)
+(maybe-define-eno EILSEQ)
+(maybe-define-eno EINPROGRESS)
+(maybe-define-eno EINTR)
+(maybe-define-eno EINVAL)
+(maybe-define-eno EIO)
+(maybe-define-eno EISCONN)
+(maybe-define-eno EISDIR)
+(maybe-define-eno EISNAM)
+(maybe-define-eno EL2HLT)
+(maybe-define-eno EL2NSYNC)
+(maybe-define-eno EL3HLT)
+(maybe-define-eno EL3RST)
+(maybe-define-eno ELIBACC)
+(maybe-define-eno ELIBBAD)
+(maybe-define-eno ELIBEXEC)
+(maybe-define-eno ELIBMAX)
+(maybe-define-eno ELIBSCN)
+(maybe-define-eno ELNRNG)
+(maybe-define-eno ELOOP)
+(maybe-define-eno EMFILE)
+(maybe-define-eno EMLINK)
+(maybe-define-eno EMSGSIZE)
+(maybe-define-eno EMULTIHOP)
+(maybe-define-eno ENAMETOOLONG)
+(maybe-define-eno ENAVAIL)
+(maybe-define-eno ENETDOWN)
+(maybe-define-eno ENETRESET)
+(maybe-define-eno ENETUNREACH)
+(maybe-define-eno ENFILE)
+(maybe-define-eno ENOANO)
+(maybe-define-eno ENOBUFS)
+(maybe-define-eno ENOCSI)
+(maybe-define-eno ENODATA)
+(maybe-define-eno ENODEV)
+(maybe-define-eno ENOENT)
+(maybe-define-eno ENOEXEC)
+(maybe-define-eno ENOLCK)
+(maybe-define-eno ENOLINK)
+(maybe-define-eno ENOMEM)
+(maybe-define-eno ENOMSG)
+(maybe-define-eno ENONET)
+(maybe-define-eno ENOPKG)
+(maybe-define-eno ENOPROTOOPT)
+(maybe-define-eno ENOSPC)
+(maybe-define-eno ENOSR)
+(maybe-define-eno ENOSTR)
+(maybe-define-eno ENOSYS)
+(maybe-define-eno ENOTBLK)
+(maybe-define-eno ENOTCONN)
+(maybe-define-eno ENOTDIR)
+(maybe-define-eno ENOTEMPTY)
+(maybe-define-eno ENOTNAM)
+(maybe-define-eno ENOTSOCK)
+(maybe-define-eno ENOTTY)
+(maybe-define-eno ENOTUNIQ)
+(maybe-define-eno ENXIO)
+(maybe-define-eno EOPNOTSUPP)
+(maybe-define-eno EOVERFLOW)
+(maybe-define-eno EPERM)
+(maybe-define-eno EPFNOSUPPORT)
+(maybe-define-eno EPIPE)
+(maybe-define-eno EPROTO)
+(maybe-define-eno EPROTONOSUPPORT)
+(maybe-define-eno EPROTOTYPE)
+(maybe-define-eno ERANGE)
+(maybe-define-eno EREMCHG)
+(maybe-define-eno EREMOTE)
+(maybe-define-eno EREMOTEIO)
+(maybe-define-eno ERESTART)
+(maybe-define-eno EROFS)
+(maybe-define-eno ESHUTDOWN)
+(maybe-define-eno ESOCKTNOSUPPORT)
+(maybe-define-eno ESPIPE)
+(maybe-define-eno ESRCH)
+(maybe-define-eno ESRMNT)
+(maybe-define-eno ESTALE)
+(maybe-define-eno ESTRPIPE)
+(maybe-define-eno ETIME)
+(maybe-define-eno ETIMEDOUT)
+(maybe-define-eno ETOOMANYREFS)
+(maybe-define-eno ETXTBSY)
+(maybe-define-eno EUCLEAN)
+(maybe-define-eno EUNATCH)
+(maybe-define-eno EUSERS)
+(maybe-define-eno EWOULDBLOCK)
+(maybe-define-eno EXDEV)
+(maybe-define-eno EXFULL)
hunk ./init.scm 1
-(define (bitwise-not a) (lognot a))
-(define (bitwise-and a b) (logand a b))
-(define (bitwise-ior a b) (logior a b))
-(define (bitwise-xor a b) (logxor a b))
-
hunk ./init.scm 18
+(define (batch-mode?) #t)
+(define (set-batch-mode?! arg) #t)
+
hunk ./init.scm 42
+(load-from-path "scsh/bitwise.scm")
hunk ./init.scm 61
+
hunk ./scsh-condition.scm 8
-(define-condition-type 'syscall-error '(error))
+;;(define-condition-type 'syscall-error '(error))
hunk ./scsh-condition.scm 10
-(define syscall-error? (condition-predicate 'syscall-error))
+;;(define syscall-error? (condition-predicate 'syscall-error))
hunk ./scsh-condition.scm 12
-;; the remainder of this file doesn't work yet in Guile.
hunk ./scsh-condition.scm 14
-    (apply signal 'syscall-error errno msg syscall stuff)))
+    (scm-error 'system-error syscall "%s" msg (list errno))))
hunk ./scsh-condition.scm 17
-  (with-handler
-    (lambda (condition more)
-      (if (syscall-error? condition)
-	  (let ((stuff (condition-stuff condition)))
-	    (handler (car stuff)	; errno
-		     (cdr stuff))))	; (msg syscall . packet)
-      (more))
-    thunk))
+  (catch 'system-error
+	 thunk
+	 (lambda args
+	   (let ((errno (car (list-ref args 4)))
+		 (message (car (list-ref args 3)))
+		 (subr (list-ref args 1)))
+	   (handler errno (list message
+				subr
+				'()))	; data
+	   (throw 'system-error subr "%s" (list-ref args 3) #f)))))
+		      
hunk ./scsh.scm 20
+;;; Like FORK, but the parent and child communicate via a pipe connecting
+;;; the parent's stdin to the child's stdout. This function side-effects
+;;; the parent by changing his stdin.
+
+(define (fork/pipe . maybe-thunk)
+  (really-fork/pipe fork maybe-thunk))
+
+(define (%fork/pipe . maybe-thunk)
+  (really-fork/pipe %fork maybe-thunk))
+  
+;;; Common code for FORK/PIPE and %FORK/PIPE.
+(define (really-fork/pipe forker maybe-thunk)
+  (receive (r w) (pipe)
+    (let ((proc (forker)))
+      (cond (proc		; Parent
+	     (close w)
+	     (move->fdes r 0))
+	    (else		; Child
+	     (close r)
+	     (move->fdes w 1)
+	     (if (pair? maybe-thunk)
+		 (call-terminally (car maybe-thunk)))))
+      proc)))
+
+
+;;; FORK/PIPE with a connection list.
+;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t)
+
+(define (%fork/pipe+ conns . maybe-thunk)
+  (really-fork/pipe+ %fork conns maybe-thunk))
+
+(define (fork/pipe+ conns . maybe-thunk)
+  (really-fork/pipe+ fork conns maybe-thunk))
+
+;;; Common code.
+(define (really-fork/pipe+ forker conns maybe-thunk)
+  (let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
+		     conns))
+	 (rev-conns (map reverse conns))
+	 (froms (map (lambda (conn) (reverse (cdr conn)))
+		     rev-conns))
+	 (tos (map car rev-conns)))
+
+    (let ((proc (forker)))
+      (cond (proc			; Parent
+	     (for-each (lambda (to r/w)
+			 (let ((w (cdr r/w))
+			       (r (car r/w)))
+			   (close w)
+			   (move->fdes r to)))
+		       tos pipes))
+
+	    (else		; Child
+	     (for-each (lambda (from r/w)
+			 (let ((r (car r/w))
+			       (w (cdr r/w)))
+			   (close r)
+			   (for-each (lambda (fd) (dup w fd)) from)
+			   (close w))) ; Unrevealed ports win.
+		       froms pipes)
+	     (if (pair? maybe-thunk)
+		 (call-terminally (car maybe-thunk)))))
+      proc)))
+
+(define (tail-pipe a b)
+  (fork/pipe a)
+  (call-terminally b))
+
+(define (tail-pipe+ conns a b)
+  (fork/pipe+ conns a)
+  (call-terminally b))
+
+;;; Lay a pipeline, one process for each thunk. Last thunk is called
+;;; in this process. PIPE* never returns.
+
+(define (pipe* . thunks)
+  (letrec ((lay-pipe (lambda (thunks)
+		       (let ((thunk (car thunks))
+			     (thunks (cdr thunks)))
+			 (if (pair? thunks)
+			     (begin (fork/pipe thunk)
+				    (lay-pipe thunks))
+			     (call-terminally thunk)))))) ; Last one.
+    (if (pair? thunks)
+	(lay-pipe thunks)
+	(error "No thunks passed to PIPE*"))))
+
+;;; Splice the processes into the i/o flow upstream from us.
+;;; First thunk's process reads from our stdin; last thunk's process'
+;;; output becomes our new stdin. Essentially, n-ary fork/pipe.
+;;;
+;;; This procedure is so trivial it isn't included.
+;;; (define (pipe-splice . thunks) (for-each fork/pipe thunks))
+
+
+
hunk ./scsh.scm 352
+(define (exec-path-search prog path-list)
+  (if (file-name-absolute? prog)
+      (and (file-executable? prog) prog)
+      (first? (lambda (dir)
+		(let ((fname (string-append dir "/" prog)))
+		  (and (file-executable? fname) fname)))
+	     path-list)))
+		    
+(define (exec/env prog env . arglist)
+  (flush-all-ports)
+  (%exec prog (cons prog arglist) env))
+
+;(define (exec-path/env prog env . arglist)
+;  (cond ((exec-path-search (stringify prog) exec-path-list) =>
+;	 (lambda (binary)
+;	   (apply exec/env binary env arglist)))
+;	(else (error "No executable found." prog arglist))))
+
+;;; This procedure is bummed by tying in directly to %%exec/errno
+;;; and pulling some of %exec's code out of the inner loop so that
+;;; the inner loop will be fast. Folks don't like waiting...
+
+(define (exec-path/env prog env . arglist)
+  (flush-all-ports)
+  (let ((prog (stringify prog)))
+    (if (index prog #\/)
+
+	;; Contains a slash -- no path search.
+	(%exec prog (cons prog (map stringify arglist)) env)
+
+	;; Try each directory in PATH-LIST.
+	(let ((arglist (cons prog (map stringify arglist))))
+	  (for-each (lambda (dir)
+		      (let ((binary (string-append dir "/" prog)))
+			(false-if-exception (%exec binary arglist env))))
+		    exec-path-list))))
+
+    (error "No executable found." prog arglist))
+	 
+(define (exec-path prog . arglist)
+  (apply exec-path/env prog #t arglist))
+
+(define (exec prog . arglist)
+  (apply exec/env prog #t arglist))
+
+
+;;; Assumes niladic primitive %%FORK.
+
+(define (fork . maybe-thunk)
+  (flush-all-ports)
+  (really-fork #t maybe-thunk))
+
+(define (%fork . maybe-thunk)
+  (really-fork #f maybe-thunk))
+
+(define (really-fork clear-interactive? maybe-thunk)
+  ((with-enabled-interrupts 0
+     (let ((pid (%%fork)))
+       (if (zero? pid)				
+
+	   ;; Child
+	   (lambda ()	; Do all this outside the WITH-INTERRUPTS.
+	     (set! reaped-procs '())
+	     (if clear-interactive?
+		 (set-batch-mode?! #t))	; Children are non-interactive.
+	     (and (pair? maybe-thunk)
+		  (call-terminally (car maybe-thunk))))
+
+	   ;; Parent
+	   (let ((proc (new-child-proc pid)))
+	     (lambda () proc)))))))
+
hunk ./scsh.scm 446
-(define home-directory "")
-(define exec-path-list '())
+(if (not (defined? 'home-directory))
+    (define home-directory ""))
+(if (not (defined? 'exec-path-list))
+    (define exec-path-list '()))
hunk ./syscalls.scm 1091
+(define errno-msg strerror)