scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

used EXEC-EPF instead of RUN in the RUN/* forms.

This commit is contained in:
eknauel 2005-08-12 13:27:27 +00:00
parent 8eedb14ef3
commit 172d0e543a
1 changed files with 36 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
scheme/job.scm
View File

@ -27,15 +27,13 @@
(add-job! job)
job))
(define (make-job-sans-console name proc . args)
(let-optionals args
((fetch-status (lambda (x) x)))
(let ((job (really-make-job
name #f proc (make-placeholder)
(define (make-job-sans-console name proc)
(let ((job (really-make-job
name #f proc (make-placeholder)
(date) #f 'running)))
(spawn-job-status-surveillant job fetch-status)
(add-job! job)
job)))
(spawn-job-status-surveillant job)
(add-job! job)
job))
(define (job-with-console? v)
(and (job? v) (job-console v)))
@ -49,11 +47,10 @@
(define (job-status job)
(sync (job-status-rv job)))
(define (spawn-job-status-surveillant job fetch-status)
(define (spawn-job-status-surveillant job)
(spawn
(lambda ()
(let ((status (fetch-status (wait (job-proc job) wait/stopped-children))))
(debug-message "job-status-surveillant, wait returned with " status)
(let ((status (wait (job-proc job) wait/stopped-children)))
(cond
((status:exit-val status)
=> (lambda (i)
@ -308,8 +305,8 @@
;; for use in Scheme mode
(define-syntax run/console
(syntax-rules ()
((_ pf)
(run/console* `(run (quote pf))))))
((_ epf)
(run/console* '(exec-epf epf)))))
;; for use in command mode (used by command-line-compiler)
(define (run/fg* s-expr)
@ -317,50 +314,32 @@
(save-tty-excursion
(current-input-port)
(lambda ()
(call-with-values
pipe
(lambda (rport wport)
(def-prog-mode)
(clear)
(endwin)
(restore-initial-tty-info! (current-input-port))
(drain-tty (current-output-port))
(obtain-lock paint-lock)
(let ((foreground-pgrp (tty-process-group (current-output-port)))
(proc
(fork
(lambda ()
;; this a forked child
(close-input-port rport)
(set-process-group (pid) (pid))
(set-tty-process-group (current-output-port) (pid))
(let ((status (eval-s-expr s-expr)))
(write status wport)
(close-output-port wport)
;; We can't call EXIT with a scsh encoded status code,
;; because the value does not fit into a byte. Sigh.
;; Send value over pipe instead.
(exit 0))))))
(close-output-port wport)
(let* ((job (make-job-sans-console
s-expr proc
;; truely evil, I think.
(lambda (ignore)
(let ((v (read rport)))
(close-input-port rport)
v))))
(status (job-status job)))
(set-tty-process-group (current-output-port) foreground-pgrp)
(newline)
(display "Press any key to return to Commander S...")
(wait-for-key)
(release-lock paint-lock)
job)))))))
(def-prog-mode)
(clear)
(endwin)
(restore-initial-tty-info! (current-input-port))
(drain-tty (current-output-port))
(obtain-lock paint-lock)
(let ((foreground-pgrp (tty-process-group (current-output-port)))
(proc
(fork
(lambda ()
(set-process-group (pid) (pid))
(set-tty-process-group (current-output-port) (pid))
(eval-s-expr s-expr)))))
(let* ((job (make-job-sans-console s-expr proc))
(status (job-status job)))
(set-tty-process-group (current-output-port) foreground-pgrp)
(newline)
(display "Press any key to return to Commander S...")
(wait-for-key)
(release-lock paint-lock)
job)))))
(define-syntax run/fg
(syntax-rules ()
((_ epf)
(run/fg* `(run ,(quote epf))))))
(run/fg* '(exec-epf epf)))))
;; for use in command mode (used by command-line-compiler)
(define (run/bg* s-expr)
@ -372,15 +351,15 @@
(lambda ()
(set-process-group (pid) (pid))
(eval-s-expr s-expr)))))
(let ((job (make-job-sans-console (quote epf) proc)))
(let ((job (make-job-sans-console s-expr proc)))
(release-lock paint-lock)
job)))
;; for use in Scheme mode
(define-syntax run/bg
(syntax-rules ()
((_ pf)
(run/bg* `(run ,(quote pf))))))
((_ epf)
(run/bg* '(exec-epf epf)))))
(define (init-evaluation-environment package)
(let ((structure (reify-structure package)))
@ -406,7 +385,7 @@
; (eval (read-sexp-from-string exp) env))))))
(define (eval-s-expr s-expr)
(debug-message "eval-s-expr " s-expr)
(debug-message "eval-s-expr " s-expr " " (pid))
(eval s-expr (evaluation-environment)))
;;; EOF