scsh-0.5/scsh/jcontrol2.scm

;;; Copyright (c) 1993 by Olin Shivers.
;;; Job control code.

(foreign-source
  "#include <sys/signal.h>"
  "#include <sys/types.h>"
  "#include <unistd.h>"
  ""
  "extern int errno;"
  ""
  "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  "" "")

;;; Fork off a process that runs in its own process group. The process is
;;; placed in its own process group before the process's actual work code is
;;; executed. We block ^Z's until we've got the child into its own proc group.

(define (fork-job . maybe-thunk)
  (flush-all-ports)
  ((with-blocked-interrupts (bitwise-ior (blocked-interrupts)	; Block ^Z.
					 (interrupt-set signal/tstp))
     (cond ((%fork) => (lambda (child) (lambda () child))) ; Parent

	   (else ; Child
	    (set-process-group (pid))	; Put ourselves in our own proc group.
	    (if (not (interrupt-handler signal/tstp))	; If ignoring TSTP,
		(set-interrupt-handler signal/tstp #t))	; reset to default.
	    (set-batch-mode?! #t)			; Batch mode.
	    (lambda () (and (pair? maybe-thunk)		; Release ^Z & do it.
			    (call-terminally (car maybe-thunk)))))))))


;;; Foreground a suspended or running background job.

(define (foreground-job proc-group)
  (let ((iport (current-input-port)))
    (cond ((and (not (batch-mode?)) (is-control-tty? iport))
	   (dynamic-wind
	       (lambda () (set-tty-process-group iport proc-group))
	       (lambda ()
		 (signal-process-group proc-group signal/cont)	; You go;
		 (wait proc-group wait/stopped-children))	; I'll wait.
	       (lambda ()
                 (with-blocked-interrupts
		         (bitwise-ior (blocked-interrupts)
				      (interrupt-set signal/ttou))
                   (set-tty-process-group iport (process-group))))))

	  ;; Oops, not really doing job control -- just wait on the process.
	  (else (signal-process proc-group signal/cont)		; You go;
	        (wait proc-group wait/stopped-children)))))	; I'll wait.

;;; Background a suspended job.

(define (background-job proc-group)
  (signal-process-group proc-group signal/cont))


(define-simple-syntax (run . epf)
  (foreground-job (& . epf)))

(define-simple-syntax (& . epf)
  (fork-job (lambda () (exec-epf . epf))))


;;; Need repl loop that manages some kind of a job table.
;;; Interactive startup must ignore ^Z.

(define *control-tty-fdes* #f)
(define (control-tty-fdes)
  (or *control-tty-fdes*
      (begin (set! *control-tty-fdes*
		   (with-errno-handler ((errno data) (else #f))
		     (open-fdes "/dev/tty" open/read)))
	     *control-tty-fdes*)))
		   
(define (is-control-tty? fd/port)
  (with-errno-handler ((errno data) (else #f))	; False if you fail.
    (tty-process-group fd/port)))		; Try it.


;;; Blocking interrupts
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (interrupt-set . interrupts)
  (let lp ((ints interrupts) (ans 0))
    (if (pair? ints)
	(lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (- (car ints) 1))))
	ans)))

(define-simple-syntax (with-blocked-interrupts mask body ...)
  (with-blocked-interrupts* mask (lambda () body ...)))

(define (with-blocked-interrupts* mask thunk)
  (let ((old-mask #f))
    (dynamic-wind
        (lambda () (set! old-mask (set-blocked-interrupts mask)))
	thunk
	(lambda () (set-blocked-interrupts old-mask)))))

(define (set-blocked-interrupts mask)
  (receive (hi-out lo-out)
      (%set-blocked-interrupts (hi8 mask) (lo24 mask))
    (compose-8/24 hi-out lo-out)))
	       

(define (blocked-interrupts)
  (call-with-values %blocked-interrupts compose-8/24))

(define-foreign %set-blocked-interrupts (set_procmask (fixnum hi)
						      (fixnum lo))
  fixnum  ; hi
  fixnum) ; lo

(define-foreign %blocked-interrupts (get_procmask)
  fixnum  ; hi
  fixnum) ; lo


;;; Get/Set interrupt handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; I'm punting the MASK value for now.
;;; I'm also punting returning real Scheme handlers for now.

(define (set-interrupt-handler interrupt handler)
  (receive (handler flags) 		; Should be (handler mask flags).
           (%set-interrupt-handler interrupt handler 0)
    handler))

(define (interrupt-handler interrupt)
  (receive (handler flags) (%interrupt-handler interrupt)
    handler))

(define (%interrupt-handler interrupt)
  (receive (err handler flags) (%%interrupt-handler interrupt)
    (if err (errno-error err interrupt-handler interrupt)
	(process-interrupt-handler-retvals handler flags))))

;;; (%set-interrupt-handler interrupt handler [mask flags]) -> [handler mask flags]
;;; Except no MASK for now.

(define (%set-interrupt-handler interrupt handler . args)
  (let-optionals args ((flags 0))
    (receive (err handler flags)
  	     (%%set-interrupt-handler interrupt handler flags)
      (if err
	  (errno-error err %set-interrupt-handler interrupt handler flags)
	  (process-interrupt-handler-retvals handler flags)))))

(define-foreign %%set-interrupt-handler (set_int_handler (fixnum signal)
							 (desc handler)
							 (fixnum flags))
  desc		; #f or errno
  desc		; handler
  fixnum)	; flags

(define-foreign %%interrupt-handler (get_int_handler (fixnum signal))
  desc		; #f or errno
  desc		; handler
  fixnum)	; flags

(define (process-interrupt-handler-retvals handler flags)
  (values (if (integer? handler)
	      (error "We don't do Scheme handlers yet.")
	      handler)
	  flags))