/usr/share/scheme48-1.9/posix/proc.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Marcus Crestani,
; Will Noble, Roderic Morris
; 3.1 Process Creation and Execution
(import-dynamic-externals "=scheme48external/posix")
;
; FORK returns the child pid in the parent, and #f in the child.
(define (fork)
(force-channel-output-ports!)
(let ((pid (posix-fork)))
(and (> pid 0) (enter-pid pid))))
(import-lambda-definition-2 posix-fork ())
; Fork off a process to execute THUNK, but don't return a pid. This avoids
; any problem with zombies.
(define (fork-and-forget thunk)
(cond ((fork)
=> wait-for-child-process)
((fork)
(exit 0))
(else
(thunk))))
;----------------
; The base Scheme procedure for exec() is EXEC-WITH-ALIAS (the `alias' is
; because the first argument may or may not be the name of the program or file).
;
; (EXEC-WITH-ALIAS program lookup? environment arguments)
; program: byte vector, name of file or program
; lookup?: should the program be looked up in PATH?
; environment: either #f, which uses the parent's environment in the child,
; or a list of byte vectors, representing text of the form "name=value".
; arguments: a list of byte vectors
(import-lambda-definition-2 external-exec-with-alias (program lookup? environment arguments)
"posix_exec")
(define (thing->exec-arg-byte-string thing)
(x->os-byte-vector thing))
(define (exec-with-alias program lookup? environment arguments)
(external-exec-with-alias (thing->exec-arg-byte-string program)
lookup?
(and environment
(map thing->exec-arg-byte-string environment))
(map thing->exec-arg-byte-string arguments)))
; Four versions of exec():
; - program looked up, use default environment
; - program looked up, environment argument
; - file used as-is, use default environment
; - file used as-is, environment argument
;
; In all cases, the program or file is added to the beginning of the list
; of arguments.
;
; When given, ENV should be a list of strings of the form "name=value".
(define (exec program . arguments)
(exec-with-alias program #t #f (cons program arguments)))
(define (exec-with-environment program env . arguments)
(exec-with-alias program #t env (cons program arguments)))
(define (exec-file file . arguments)
(exec-with-alias file #f #f (cons file arguments)))
(define (exec-file-with-environment file env . arguments)
(exec-with-alias file #f env (cons file arguments)))
;----------------
; Process ids
;
; Threads can wait for child process to terminate. This requires polling,
; which in turn requires that we store the child's return status or terminating
; signal for later use. Hence the extra fields.
;
; These should probably not be dumpable.
;
; Because these have state they must be unique. The C code keeps a weak
; list of existing ones.
(define-record-type process-id :process-id
(make-process-id uid exit-status terminating-signal placeholder)
process-id?
(uid process-id->integer) ; the Unix PID
; The rest are initially #F and are set as events warrant.
(exit-status process-id-exit-status set-process-id-exit-status!)
(terminating-signal process-id-terminating-signal set-process-id-terminating-signal!)
(placeholder process-id-placeholder))
(define-record-discloser :process-id
(lambda (process-id)
(list 'process-id (process-id->integer process-id))))
; Invalidate process IDs on resuming image.
(define-record-resumer :process-id #f)
(define *process-ids* (make-population))
(define-reinitializer process-id-reinitializer
(lambda () (set! *process-ids* (make-population))))
(define (process-id=? p1 p2)
(if (and (process-id? p1)
(process-id? p2))
(eq? p1 p2)
(assertion-violation 'process-id=? "argument type error" p1 p2)))
(define (enter-pid num)
(let ((pid (make-process-id num #f #f (make-placeholder))))
(add-to-population! pid *process-ids*)
pid))
(define (lookup-pid num)
(call-with-current-continuation
(lambda (return)
(walk-population
(lambda (pid)
(if (= num (process-id->integer pid)) (return pid)))
*process-ids*)
#f)))
(define (integer->process-id num) (or (lookup-pid num) (enter-pid num)))
;----------------
; 3.2 Process Termination
;
; pid_t wait(int *stat_loc)
; pid_t waitpid(pid_t pid, int *stat_loc, int options)
; void _exit(int status); Need to do this.
; Wait for a child process.
(define (wait-for-child-process pid)
(placeholder-value (process-id-placeholder pid) #f)
(values))
; Waiting for children. We go through the terminated child processes
; until we we run out. This needs to be called by the SIGCHLD
; handler.
(define (process-terminated-children)
(let loop ()
(cond
((posix-waitpid)
=> (lambda (next)
(cond
((lookup-pid (vector-ref next 0))
=> (lambda (pid)
(set-process-id-exit-status! pid (vector-ref next 1))
(set-process-id-terminating-signal!
pid
(and (vector-ref next 2)
(integer->signal (vector-ref next 2))))
(placeholder-set! (process-id-placeholder pid) #t))))
(loop))))))
(import-lambda-definition-2 posix-waitpid ())
(define (exit status)
(force-channel-output-ports!)
(scheme-exit-now status))
|