Almost pure Scheme version of process-execute added by sjamaan on Mon Jul 25 22:38:35 2016
(define process-execute
(let* ((pathname-strip-directory pathname-strip-directory)
(c-string->allocated-pointer
(foreign-lambda* c-pointer ((scheme-object o))
"char *ptr = malloc(C_header_size(o)); \n"
"if (ptr != NULL) {\n"
" C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n"
"}\n"
"C_return(ptr);"))
(free-buffer-array
(lambda (buffer-array)
(let ((size (pointer-vector-length buffer-array)))
(do ((i 0 (fx+ i 1)))
((fx= i size))
(and-let* ((s (pointer-vector-ref buffer-array i)))
(free s))))))
(copy&set-c-string!
(lambda (buffer-array i s)
;; This avoids embedded NULs and appends a NUL, so "cs" is
;; safe to copy and use as-is in the pointer-vector.
(let* ((cs (##sys#make-c-string s 'process-execute))
(csp (c-string->allocated-pointer cs)))
(unless csp (error "Out of memory in process-execute"))
(pointer-vector-set! buffer-array i csp))))
;; TODO: Dynamically determine
(arg-max (foreign-value "ARG_MAX" size_t))
(env-max (foreign-value "ENV_MAX" size_t))
(execvp (foreign-lambda int "C_execvp"
c-string pointer-vector))
(execve (foreign-lambda int "C_execve"
c-string pointer-vector pointer-vector)))
(lambda (filename #!optional (arglist '()) envlist)
(##sys#check-string filename 'process-execute)
(##sys#check-list arglist 'process-execute)
(when envlist (##sys#check-list envlist 'process-execute))
(let* ((stripped-filename (pathname-strip-directory filename))
(argcount (##sys#length arglist))
(envcount (and envlist (##sys#length envlist)))
;; NUL-terminated, so we must add one, and we also store
;; the filename in argv[0], so add another.
(argbuf (make-pointer-vector (+ argcount 2) #f))
(envbuf (and envcount
(make-pointer-vector (+ envcount 1) #f))))
;; TODO: Check before making the vector? Doesn't matter much.
(##sys#check-range argcount 0 arg-max 'process-execute)
(when envlist
(##sys#check-range envcount 0 env-max 'process-execute))
(handle-exceptions exn
;; Free to avoid memory leak, then reraise
(begin (free-buffer-array argbuf)
(when envbuf (free-buffer-array envbuf))
(signal exn))
(copy&set-c-string! argbuf 0 stripped-filename)
(do ((al arglist (cdr al))
(i 1 (fx+ i 1)) )
((or (null? al) (fx> i argcount))) ; Should coincide
(copy&set-c-string! argbuf i (car al)) )
(do ((el (or envlist '()) (cdr el))
(i 0 (fx+ i 1)) )
((or (null? el) (fx= i envcount))) ; Should coincide
(copy&set-c-string! envbuf i (car el)) )
(let ((r (if envlist
(execve filename argbuf envbuf)
(execvp filename argbuf) )) )
(when (fx= r -1)
(posix-error #:process-error 'process-execute "cannot execute process" filename) ) ))) ) ) )