~ chicken-core (chicken-5) aaa0c6a799e9e87226187ffff92c7afb2f6f3ff2
commit aaa0c6a799e9e87226187ffff92c7afb2f6f3ff2
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jun 27 09:52:05 2025 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jun 27 09:52:05 2025 +0200
ddrop pointless conversion procedure argument, fix off-by-one when creating execargs stringlists
diff --git a/posix-common.scm b/posix-common.scm
index 237fd272..50d892a4 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -785,26 +785,26 @@ EOF
(define call-with-exec-args
(let ((nop (lambda (x) x)))
- (lambda (loc filename argconv arglist envlist proc)
+ (lambda (loc filename arglist envlist proc)
(let* ((args (cons filename arglist)) ; Add argv[0]
- (argbuf (list->c-string-buffer args argconv loc))
- (envbuf #f))
-
- (handle-exceptions exn
- ;; Free to avoid memory leak, then reraise
- (begin (free-c-string-buffer argbuf)
- (when envbuf (free-c-string-buffer envbuf))
- (signal exn))
-
- ;; Envlist is never converted, so we always use nop here
- (when envlist
- (check-environment-list envlist loc)
- (set! envbuf
- (list->c-string-buffer
- (map (lambda (p) (string-append (car p) "=" (cdr p))) envlist)
- nop loc)))
-
- (proc (##sys#make-c-string filename loc) argbuf envbuf))))))
+ (argbuf (list->c-string-buffer args (lambda (x) x) loc))
+ (envbuf #f))
+
+ (handle-exceptions exn
+ ;; Free to avoid memory leak, then reraise
+ (begin (free-c-string-buffer argbuf)
+ (when envbuf (free-c-string-buffer envbuf))
+ (signal exn))
+
+ ;; Envlist is never converted, so we always use nop here
+ (when envlist
+ (check-environment-list envlist loc)
+ (set! envbuf
+ (list->c-string-buffer
+ (map (lambda (p) (string-append (car p) "=" (cdr p))) envlist)
+ nop loc)))
+
+ (proc (##sys#make-c-string filename loc) argbuf envbuf))))))
;; Pipes:
diff --git a/posixunix.scm b/posixunix.scm
index 7b539d2a..8ed61ea6 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1126,30 +1126,30 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(set! chicken.process#process-execute
(lambda (filename #!optional (arglist '()) envlist _)
(call-with-exec-args
- 'process-execute filename (lambda (x) x) arglist envlist
+ 'process-execute filename arglist envlist
(lambda (prg argbuf envbuf)
(let ((r (if envbuf
- (##core#inline "C_u_i_execve" prg argbuf envbuf)
- (##core#inline "C_u_i_execvp" prg argbuf))))
- (when (fx= r -1)
- (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))
+ (##core#inline "C_u_i_execve" prg argbuf envbuf)
+ (##core#inline "C_u_i_execvp" prg argbuf))))
+ (when (fx= r -1)
+ (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))
(define-foreign-variable _wnohang int "WNOHANG")
(define-foreign-variable _wait-status int "C_wait_status")
(define (process-wait-impl pid nohang)
(let* ((res (##core#inline "C_waitpid" pid (if nohang _wnohang 0)))
- (norm (##core#inline "C_WIFEXITED" _wait-status)) )
+ (norm (##core#inline "C_WIFEXITED" _wait-status)) )
(if (and (fx= res -1) (fx= _errno _eintr))
- (##sys#dispatch-interrupt
+ (##sys#dispatch-interrupt
(lambda () (process-wait-impl pid nohang)))
- (values
- res
- norm
- (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status))
- ((##core#inline "C_WIFSIGNALED" _wait-status)
- (##core#inline "C_WTERMSIG" _wait-status))
- (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) )
+ (values
+ res
+ norm
+ (cond (norm (##core#inline "C_WEXITSTATUS" _wait-status))
+ ((##core#inline "C_WIFSIGNALED" _wait-status)
+ (##core#inline "C_WTERMSIG" _wait-status))
+ (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) )
(set! chicken.process-context.posix#parent-process-id (foreign-lambda int "C_getppid"))
diff --git a/posixwin.scm b/posixwin.scm
index c4373e62..e4ed6301 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -735,33 +735,32 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(define c-string->allocated-pointer
(foreign-lambda* c-pointer ((scheme-object o))
- "int len = C_header_size(o) * sizeof(wchar_t); \n"
+ ;; includes 0 byte at end
+ "int len = C_header_size(o) * sizeof(C_WCHAR); \n"
"char *ptr = C_malloc(len); \n"
"if (ptr != NULL) {\n"
- " wchar_t *u = C_utf16(o, 0); \n"
- " C_memcpy(ptr, u, len + 1); \n"
+ " C_WCHAR *u = C_utf16(o, 0); \n"
+ " C_memcpy(ptr, u, len); \n"
"}\n"
"C_return(ptr);"))
(set! chicken.process#process-execute
(lambda (filename #!optional (arglist '()) envlist exactf)
- (let ((argconv (lambda (x) x)))
- (call-with-exec-args
- 'process-execute filename argconv arglist envlist
+ (call-with-exec-args
+ 'process-execute filename arglist envlist
(lambda (prg argbuf envbuf)
- (##core#inline "C_flushall")
- (let ((r (if envbuf
- (##core#inline "C_u_i_execve" prg argbuf envbuf)
- (##core#inline "C_u_i_execvp" prg argbuf))))
- (when (fx= r -1)
- (posix-error #:process-error 'process-execute "cannot execute process" filename))))))))
+ (##core#inline "C_flushall")
+ (let ((r (if envbuf
+ (##core#inline "C_u_i_execve" prg argbuf envbuf)
+ (##core#inline "C_u_i_execvp" prg argbuf))))
+ (when (fx= r -1)
+ (posix-error #:process-error 'process-execute "cannot execute process" filename)))))))
(set! chicken.process#process-spawn
(lambda (mode filename #!optional (arglist '()) envlist exactf)
- (let ((argconv (lambda (x) x)))
(##sys#check-fixnum mode 'process-spawn)
(call-with-exec-args
- 'process-spawn filename argconv arglist envlist
+ 'process-spawn filename arglist envlist
(lambda (prg argbuf envbuf)
(##core#inline "C_flushall")
(let ((r (if envbuf
@@ -770,14 +769,14 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(if (fx= r -1)
(posix-error #:process-error 'process-spawn
"cannot spawn process" filename)
- (register-pid r))))))))
+ (register-pid r)))))))
(define-foreign-variable _shlcmd c-string "C_shlcmd")
(define (shell-command loc)
(or (get-environment-variable "COMSPEC")
(if (##core#inline "C_get_shlcmd")
- _shlcmd
+ _shlcmd
(##sys#error/errno
(##sys#update-errno) loc "cannot retrieve system directory"))))
@@ -788,12 +787,12 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(lambda (f . args)
(let ((args (if (pair? args) (car args) #f)))
(if args
- (chicken.process#process-spawn
- chicken.process#spawn/nowait f args)
- (chicken.process#process-spawn
- chicken.process#spawn/nowait
- (shell-command 'process-run)
- (shell-command-arguments f)) ) ) ) )
+ (chicken.process#process-spawn
+ chicken.process#spawn/nowait f args)
+ (chicken.process#process-spawn
+ chicken.process#spawn/nowait
+ (shell-command 'process-run)
+ (shell-command-arguments f)) ) ) ) )
;;; Run subprocess connected with pipes:
(define-foreign-variable _rdbuf char "C_rdbuf")
@@ -802,13 +801,13 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
; from original by Mejedi
;; process-impl
-; loc caller procedure symbol
-; cmd pathname or commandline
-; args string-list or '()
-; env string-list or #f (currently ignored)
-; stdoutf #f then share, or #t then create
-; stdinf #f then share, or #t then create
-; stderrf #f then share, or #t then create
+; loc caller procedure symbol
+; cmd pathname or commandline
+; args string-list or '()
+; env string-list or #f (currently ignored)
+; stdoutf #f then share, or #t then create
+; stdinf #f then share, or #t then create
+; stderrf #f then share, or #t then create
;
; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
; where stdin-input-port?, etc. is a port or #f, indicating no port created.
@@ -816,8 +815,8 @@ static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
(define process-impl
;; XXX TODO: When environment is implemented, check for embedded NUL bytes!
(let ([c-process
- (foreign-lambda bool "C_process" c-string scheme-object c-pointer
- (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int) int)])
+ (foreign-lambda bool "C_process" c-string scheme-object c-pointer
+ (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int) int)])
; The environment list must be sorted & include current directory
; information for the system drives. i.e !C:=...
; For now any environment is ignored.
Trap