blob: 74727ce20a4bc03ed47dcc1478f09231cd1efbd9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
;;
;; SCSH process form notation
;;
;; See http://www.scsh.net/docu/html/man-Z-H-3.html#node_chap_2
;;
;; Some minor changes due to Chicken- and R7RS-incompatible identifiers:
;; | was changed to pipe, |+ was changed to pipe+
;;
;; || wasn't changed, but it's really the zero-length symbol
;;
(module scsh-process
((& maybe-symbol->string) (run maybe-symbol->string) (exec-epf maybe-symbol->string)
exec-path)
(import chicken scheme data-structures)
(use posix)
(define-syntax &
(syntax-rules ()
((_ ?epf ...)
(process-fork (lambda ()
(handle-exceptions exn
;; TODO: Figure out how SCSH does this. It shows the error
;; on stderr in the REPL, but then still quits it.
;; If we just invoke current-handler, it'll get a second REPL
(begin (print-error-message exn) (exit 1))
(exec-epf ?epf ...)))))))
(define-syntax run
(syntax-rules ()
((_ ?epf ...)
;; We reorder the values as they make more sense this way for SCSH compat:
;; scsh returns just the exit code, and conveniently we allow MV in single
;; value continuations, which makes it compatible.
(receive (pid normal-exit? exit-status)
(process-wait (& ?epf ...))
(values exit-status normal-exit? pid)))))
(define (maybe-symbol->string s)
(if (symbol? s) (symbol->string s) s))
;; Perhaps this should really be a procedure?
(define-syntax setup-redirection
(syntax-rules (< > << >> = - stdports)
((_ (< ?file-name)) (setup-redirection (< 0 ?file-name)))
((_ (> ?file-name)) (setup-redirection (> 1 ?file-name)))
((_ (<< ?object)) (setup-redirection (<< 0 ?object)))
((_ (>> ?object)) (setup-redirection (>> 1 ?object)))
((_ (< ?fd ?file-name))
(duplicate-fileno (file-open (maybe-symbol->string `?file-name)
open/rdonly)
`?fd))
((_ (> ?fd ?file-name))
(duplicate-fileno (file-open (maybe-symbol->string `?file-name)
(fx+ open/wronly open/creat))
`?fd))
((_ (<< ?fd ?object)) (error "<< currently not implemented"))
((_ (>> ?fd ?object)) (error ">> currently not implemented"))
((_ (= ?fd-from ?fd/port-to))
(let* ((fd/port-to ?fd/port-to) ; Evaluate once
(fd-to (if (port? fd/port-to)
(port->fileno fd/port-to)
fd/port-to)))
(duplicate-fileno ?fd-from fd-to)))
((_ (- ?fd/port))
(let ((o `?fd/port))
(cond
((fixnum? ?fd/port) (file-close o))
((output-port? ?fd/port) (close-output-port o))
((input-port? ?fd/port) (close-input-port o))
(else (error "Can only close i/o-ports and file descriptor numbers" o)))))
((_ stdports)
(begin (setup-redirection (= 0 (current-input-port)))
(setup-redirection (= 1 (current-output-port)))
(setup-redirection (= 2 (current-error-port)))))
((_ ?arg0 ...)
(syntax-error "Invalid redirection pattern: " `?arg0 ...))))
;; The most "core" syntax form
(define-syntax exec-epf
(syntax-rules (begin)
((_ (begin ?expr0 ...))
(begin (setup-redirection (= 0 (current-input-port)))
(setup-redirection (= 1 (current-output-port)))
(setup-redirection (= 2 (current-error-port)))
?expr0 ...))
((_ (?prog ?arg0 ...) ?redir0 ...)
(begin
(setup-redirection ?redir0) ...
(exec-path `?prog `?arg0 ...)))))
;; TODO: Perhaps expose environment, and mess around with the path so that
;; execve can be used in a sensible way? Scsh has its own PATH, so we could
;; use something similar to that, but it's more work.
(define (exec-path prog . args)
(process-execute (maybe-symbol->string prog) (map maybe-symbol->string args)))
)
|
