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

51
scheme/job.scm
View File

@ -27,15 +27,13 @@
(add-job! job) (add-job! job)
job)) job))
(define (make-job-sans-console name proc . args) (define (make-job-sans-console name proc)
(let-optionals args
((fetch-status (lambda (x) x)))
(let ((job (really-make-job (let ((job (really-make-job
name #f proc (make-placeholder) name #f proc (make-placeholder)
(date) #f 'running))) (date) #f 'running)))
(spawn-job-status-surveillant job fetch-status) (spawn-job-status-surveillant job)
(add-job! job) (add-job! job)
job))) job))
(define (job-with-console? v) (define (job-with-console? v)
(and (job? v) (job-console v))) (and (job? v) (job-console v)))
@ -49,11 +47,10 @@
(define (job-status job) (define (job-status job)
(sync (job-status-rv job))) (sync (job-status-rv job)))
(define (spawn-job-status-surveillant job fetch-status) (define (spawn-job-status-surveillant job)
(spawn (spawn
(lambda () (lambda ()
(let ((status (fetch-status (wait (job-proc job) wait/stopped-children)))) (let ((status (wait (job-proc job) wait/stopped-children)))
(debug-message "job-status-surveillant, wait returned with " status)
(cond (cond
((status:exit-val status) ((status:exit-val status)
=> (lambda (i) => (lambda (i)
@ -308,8 +305,8 @@
;; for use in Scheme mode ;; for use in Scheme mode
(define-syntax run/console (define-syntax run/console
(syntax-rules () (syntax-rules ()
((_ pf) ((_ epf)
(run/console* `(run (quote pf)))))) (run/console* '(exec-epf epf)))))
;; for use in command mode (used by command-line-compiler) ;; for use in command mode (used by command-line-compiler)
(define (run/fg* s-expr) (define (run/fg* s-expr)
@ -317,9 +314,6 @@
(save-tty-excursion (save-tty-excursion
(current-input-port) (current-input-port)
(lambda () (lambda ()
(call-with-values
pipe
(lambda (rport wport)
(def-prog-mode) (def-prog-mode)
(clear) (clear)
(endwin) (endwin)
@ -330,37 +324,22 @@
(proc (proc
(fork (fork
(lambda () (lambda ()
;; this a forked child
(close-input-port rport)
(set-process-group (pid) (pid)) (set-process-group (pid) (pid))
(set-tty-process-group (current-output-port) (pid)) (set-tty-process-group (current-output-port) (pid))
(let ((status (eval-s-expr s-expr))) (eval-s-expr s-expr)))))
(write status wport) (let* ((job (make-job-sans-console s-expr proc))
(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))) (status (job-status job)))
(set-tty-process-group (current-output-port) foreground-pgrp) (set-tty-process-group (current-output-port) foreground-pgrp)
(newline) (newline)
(display "Press any key to return to Commander S...") (display "Press any key to return to Commander S...")
(wait-for-key) (wait-for-key)
(release-lock paint-lock) (release-lock paint-lock)
job))))))) job)))))
(define-syntax run/fg (define-syntax run/fg
(syntax-rules () (syntax-rules ()
((_ epf) ((_ epf)
(run/fg* `(run ,(quote epf)))))) (run/fg* '(exec-epf epf)))))
;; for use in command mode (used by command-line-compiler) ;; for use in command mode (used by command-line-compiler)
(define (run/bg* s-expr) (define (run/bg* s-expr)
@ -372,15 +351,15 @@
(lambda () (lambda ()
(set-process-group (pid) (pid)) (set-process-group (pid) (pid))
(eval-s-expr s-expr))))) (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) (release-lock paint-lock)
job))) job)))
;; for use in Scheme mode ;; for use in Scheme mode
(define-syntax run/bg (define-syntax run/bg
(syntax-rules () (syntax-rules ()
((_ pf) ((_ epf)
(run/bg* `(run ,(quote pf)))))) (run/bg* '(exec-epf epf)))))
(define (init-evaluation-environment package) (define (init-evaluation-environment package)
(let ((structure (reify-structure package))) (let ((structure (reify-structure package)))
@ -406,7 +385,7 @@
; (eval (read-sexp-from-string exp) env)))))) ; (eval (read-sexp-from-string exp) env))))))
(define (eval-s-expr s-expr) (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))) (eval s-expr (evaluation-environment)))
;;; EOF ;;; EOF