~ chicken-core (chicken-5) 251e3ce628dcfa5d8a6bfa5b128f4cc4fb4c1b8b
commit 251e3ce628dcfa5d8a6bfa5b128f4cc4fb4c1b8b
Author: Mario Domenech Goulart <mario@parenteses.org>
AuthorDate: Sat Jan 6 19:43:04 2024 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jan 7 12:09:40 2024 +0100
Add errno property to condition objects
From c9f4b699a907f1b619fdb11e0051cc697decf2cf Mon Sep 17 00:00:00 2001
From: Mario Domenech Goulart <mario@parenteses.org>
Date: Sat, 6 Jan 2024 13:12:40 +0100
Subject: [PATCH] Add errno property to condition objects
This change introduces two new internal procedures that inject errno
into condition objects produced by procedures whose underlying C calls
update it:
* ##sys#error/errno
* ##sys#signal-hook/errno
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/NEWS b/NEWS
index ffb42e1e..46c5d423 100644
--- a/NEWS
+++ b/NEWS
@@ -33,6 +33,8 @@
export.
- The values of the TMPDIR, TMP and TEMP environment variables are no
longer memoized (fixes #1830).
+ - Condition objects produced by procedures that change errno now have
+ an `errno' property.
- Tools
- The -R option for csi and csc now accepts list-notation like
diff --git a/file.scm b/file.scm
index 78d68a41..f8f45bd9 100644
--- a/file.scm
+++ b/file.scm
@@ -116,7 +116,8 @@ EOF
[string-append string-append] )
(lambda (type loc msg . args)
(let ([rn (##sys#update-errno)])
- (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+ (apply ##sys#signal-hook/errno
+ type rn loc (string-append msg " - " (strerror rn)) args)))))
;;; Existence checks:
@@ -225,11 +226,10 @@ EOF
(define (delete-file filename)
(##sys#check-string filename 'delete-file)
(unless (eq? 0 (##core#inline "C_remove" (##sys#make-c-string filename 'delete-file)))
- (##sys#update-errno)
- (##sys#signal-hook
- #:file-error 'delete-file
- (##sys#string-append "cannot delete file - " strerror) filename))
- filename)
+ (##sys#signal-hook/errno
+ #:file-error (##sys#update-errno) 'delete-file
+ (##sys#string-append "cannot delete file - " strerror) filename)
+ filename))
(define (delete-file* file)
(and (file-exists? file) (delete-file file)))
@@ -243,9 +243,8 @@ EOF
"C_rename"
(##sys#make-c-string oldfile 'rename-file)
(##sys#make-c-string newfile 'rename-file)))
- (##sys#update-errno)
- (##sys#signal-hook
- #:file-error 'rename-file
+ (##sys#signal-hook/errno
+ #:file-error (##sys#update-errno) 'rename-file
(##sys#string-append "cannot rename file - " strerror) oldfile newfile))
newfile)
diff --git a/library.scm b/library.scm
index 7341bb66..3ec87a74 100644
--- a/library.scm
+++ b/library.scm
@@ -40,7 +40,7 @@
+maximum-allowed-exponent+ mantexp->dbl ldexp round-quotient
##sys#string->compnum ##sys#internal-gcd)
(not inline chicken.base#sleep-hook ##sys#change-directory-hook
- ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook
+ ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#signal-hook/errno
##sys#default-read-info-hook ##sys#infix-list-hook
##sys#sharp-number-hook ##sys#user-print-hook
##sys#user-interrupt-hook ##sys#windows-platform
@@ -1049,6 +1049,11 @@ EOF
(define ##sys#warn warning)
(define ##sys#notice notice)
+(define (##sys#error/errno err . args)
+ (if (pair? args)
+ (apply ##sys#signal-hook/errno #:error err #f args)
+ (##sys#signal-hook/errno #:error err #f)))
+
(define-foreign-variable strerror c-string "strerror(errno)")
(define ##sys#gc (##core#primitive "C_gc"))
@@ -3225,24 +3230,26 @@ EOF
(let ((c (##core#inline "C_read_char" p)))
(cond
((eq? -1 c)
- (if (eq? (##sys#update-errno) (foreign-value "EINTR" int))
- (##sys#dispatch-interrupt loop)
- (##sys#signal-hook
- #:file-error 'read-char
- (##sys#string-append "cannot read from port - " strerror)
- p)))
+ (let ((err (##sys#update-errno)))
+ (if (eq? err (foreign-value "EINTR" int))
+ (##sys#dispatch-interrupt loop)
+ (##sys#signal-hook/errno
+ #:file-error err 'read-char
+ (##sys#string-append "cannot read from port - " strerror)
+ p))))
(else c)))))
(lambda (p) ; peek-char
(let loop ()
(let ((c (##core#inline "C_peek_char" p)))
(cond
((eq? -1 c)
- (if (eq? (##sys#update-errno) (foreign-value "EINTR" int))
- (##sys#dispatch-interrupt loop)
- (##sys#signal-hook
- #:file-error 'peek-char
- (##sys#string-append "cannot read from port - " strerror)
- p)))
+ (let ((err (##sys#update-errno)))
+ (if (eq? err (foreign-value "EINTR" int))
+ (##sys#dispatch-interrupt loop)
+ (##sys#signal-hook/errno
+ #:file-error err 'peek-char
+ (##sys#string-append "cannot read from port - " strerror)
+ p))))
(else c)))))
(lambda (p c) ; write-char
(##core#inline "C_display_char" p c) )
@@ -3261,14 +3268,15 @@ EOF
(cond ((eof-object? len) ; EOF returns 0 bytes read
act)
((fx< len 0)
- (if (eq? (##sys#update-errno) (foreign-value "EINTR" int))
- (##sys#dispatch-interrupt
- (lambda ()
- (loop (fx- rem len) (fx+ act len) (fx+ start len))))
- (##sys#signal-hook
- #:file-error 'read-string!
- (##sys#string-append "cannot read from port - " strerror)
- p n dest start)))
+ (let ((err (##sys#update-errno)))
+ (if (eq? err (foreign-value "EINTR" int))
+ (##sys#dispatch-interrupt
+ (lambda ()
+ (loop (fx- rem len) (fx+ act len) (fx+ start len))))
+ (##sys#signal-hook/errno
+ #:file-error err 'read-string!
+ (##sys#string-append "cannot read from port - " strerror)
+ p n dest start))))
((fx< len rem)
(loop (fx- rem len) (fx+ act len) (fx+ start len)))
(else
@@ -3295,18 +3303,19 @@ EOF
(##sys#string-append result buffer)
#t)) ]
((fx< n 0)
- (if (eq? (##sys#update-errno) (foreign-value "EINTR" int))
- (let ((n (fx- (fxneg n) 1)))
- (##sys#dispatch-interrupt
- (lambda ()
- (loop len limit buffer
- (##sys#string-append
- result (##sys#substring buffer 0 n))
- #t))))
- (##sys#signal-hook
- #:file-error 'read-line
- (##sys#string-append "cannot read from port - " strerror)
- p rlimit)))
+ (let ((err (##sys#update-errno)))
+ (if (eq? err (foreign-value "EINTR" int))
+ (let ((n (fx- (fxneg n) 1)))
+ (##sys#dispatch-interrupt
+ (lambda ()
+ (loop len limit buffer
+ (##sys#string-append
+ result (##sys#substring buffer 0 n))
+ #t))))
+ (##sys#signal-hook/errno
+ #:file-error err 'read-line
+ (##sys#string-append "cannot read from port - " strerror)
+ p rlimit))))
[f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
(##sys#string-append result (##sys#substring buffer 0 n))]
[else
@@ -3400,8 +3409,9 @@ EOF
[else (##sys#error loc "invalid file option" o)] ) ) )
(let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class name 'stream)))
(unless (##sys#open-file-port port name (##sys#string-append fmode bmode))
- (##sys#update-errno)
- (##sys#signal-hook #:file-error loc (##sys#string-append "cannot open file - " strerror) name) )
+ (##sys#signal-hook/errno #:file-error (##sys#update-errno) loc
+ (##sys#string-append "cannot open file - " strerror)
+ name))
port) ) )
(define (close port inp loc)
@@ -5105,7 +5115,7 @@ EOF
(import scheme chicken.base chicken.fixnum chicken.foreign)
(import chicken.internal.syntax)
-(define (##sys#signal-hook mode msg . args)
+(define (##sys#signal-hook/errno mode errno msg . args)
(##core#inline "C_dbg_hook" #f)
(##core#inline "signal_debug_event" mode msg args)
(case mode
@@ -5132,7 +5142,7 @@ EOF
(##sys#write-char-0 #\newline ##sys#standard-error))))
args)
(##sys#flush-output ##sys#standard-error)]
- [else
+ (else
(when (and (symbol? msg) (null? args))
(set! msg (symbol->string msg)))
(let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
@@ -5158,10 +5168,19 @@ EOF
[(#:domain-error) '(exn domain)]
((#:memory-error) '(exn memory))
[else '(exn)] )
- (list '(exn . message) msg
- '(exn . arguments) args
- '(exn . call-chain) (get-call-chain)
- '(exn . location) loc) ) ) ) ] ) )
+ (let ((props
+ (list '(exn . message) msg
+ '(exn . arguments) args
+ '(exn . call-chain) (get-call-chain)
+ '(exn . location) loc)))
+ (if errno
+ (cons '(exn . errno) (cons errno props))
+ props))))))))
+
+(define (##sys#signal-hook mode msg . args)
+ (if (pair? args)
+ (apply ##sys#signal-hook/errno mode #f msg args)
+ (##sys#signal-hook/errno mode #f msg)))
(define (abort x)
(##sys#current-exception-handler x)
@@ -6034,8 +6053,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(##sys#check-string name 'change-directory)
(let ((sname (##sys#make-c-string name 'change-directory)))
(unless (fx= (##core#inline "C_chdir" sname) 0)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'change-directory
+ (##sys#signal-hook/errno #:file-error (##sys#update-errno) 'change-directory
(string-append "cannot change current directory - " strerror) name))
name))
@@ -6052,9 +6070,10 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(##sys#update-errno))
(if len
(##sys#substring buffer 0 len)
- (##sys#signal-hook
- #:file-error
- 'current-directory "cannot retrieve current directory"))))
+ (##sys#signal-hook/errno
+ #:file-error
+ (##sys#errno)
+ 'current-directory "cannot retrieve current directory"))))
(lambda (dir)
(##sys#change-directory-hook dir))
"(chicken.process-context#current-directory)"))
diff --git a/manual/Module (chicken condition) b/manual/Module (chicken condition)
index 522b51f5..d057f427 100644
--- a/manual/Module (chicken condition)
+++ b/manual/Module (chicken condition)
@@ -102,6 +102,10 @@ possible. If the unwinding and handling of the signal raises one of
these signals once again, the process will abort with an error
message.
+* New in CHICKEN 5.4.0: condition objects produced by procedures that
+change errno have an {{errno}} property. To access it, use
+{{(get-condition-property <the-condition-object> 'exn 'errno)}}.
+
=== Additional API
==== condition-case
diff --git a/manual/Module (chicken file posix) b/manual/Module (chicken file posix)
index 1140ef19..14e95132 100644
--- a/manual/Module (chicken file posix)
+++ b/manual/Module (chicken file posix)
@@ -13,6 +13,11 @@ systems like Windows. See below for Windows specific notes.
All errors related to failing file-operations will signal a condition
of kind {{(exn i/o file)}}.
+* New in CHICKEN 5.4.0: Errors caused by underlying C calls that
+ change errno will produce a condition object with an {{errno}}
+ property, which can be accessed with
+ {{(get-condition-property <the-condition-object> 'exn 'errno)}}.
+
=== Constants
==== File-control Commands
diff --git a/manual/Module (chicken file) b/manual/Module (chicken file)
index 4dd96d08..e2804508 100644
--- a/manual/Module (chicken file)
+++ b/manual/Module (chicken file)
@@ -10,6 +10,11 @@ directories. For more specific operations, see also
All errors related to failing file-operations will signal a condition
of kind {{(exn i/o file)}}.
+* New in CHICKEN 5.4.0: Errors caused by underlying C calls that
+ change errno will produce a condition object with an {{errno}}
+ property, which can be accessed with
+ {{(get-condition-property <the-condition-object> 'exn 'errno)}}.
+
=== Basic file operations
==== create-directory
diff --git a/manual/Module (chicken port) b/manual/Module (chicken port)
index 996b87ff..ba8c268f 100644
--- a/manual/Module (chicken port)
+++ b/manual/Module (chicken port)
@@ -5,6 +5,14 @@
This module contains various extended port definitions.
+All errors related to failing port operations will signal a condition
+of kind {{exn}}.
+
+* New in CHICKEN 5.4.0: Errors caused by underlying C calls that
+ change errno will produce a condition object with an {{errno}}
+ property, which can be accessed with
+ {{(get-condition-property <the-condition-object> 'exn 'errno)}}.
+
=== Port attributes
==== port-name
diff --git a/manual/Module (chicken process) b/manual/Module (chicken process)
index 26f225c3..3105798a 100644
--- a/manual/Module (chicken process)
+++ b/manual/Module (chicken process)
@@ -5,6 +5,10 @@
This module offers procedures for interacting with subprocesses.
+* New in CHICKEN 5.4.0: Errors caused by underlying C calls that
+ change errno will produce a condition object with an {{errno}}
+ property, which can be accessed with
+ {{(get-condition-property <the-condition-object> 'exn 'errno)}}.
=== Processes
diff --git a/manual/Module (chicken process-context posix) b/manual/Module (chicken process-context posix)
index 0b4e9426..192ba588 100644
--- a/manual/Module (chicken process-context posix)
+++ b/manual/Module (chicken process-context posix)
@@ -6,6 +6,11 @@
This module provides access to POSIX-specific procedures which deal
with the current process context.
+* New in CHICKEN 5.4.0: Errors caused by underlying C calls that
+ change errno will produce a condition object with an {{errno}}
+ property, which can be accessed with
+ {{(get-condition-property <the-condition-object> 'exn 'errno)}}.
+
=== Process filesystem context
==== change-directory*
diff --git a/manual/Module (chicken process-context) b/manual/Module (chicken process-context)
index 87165187..b30f4d08 100644
--- a/manual/Module (chicken process-context)
+++ b/manual/Module (chicken process-context)
@@ -5,6 +5,11 @@
This module provides access to the current process context.
+* New in CHICKEN 5.4.0: Errors caused by underlying C calls that
+ change errno will produce a condition object with an {{errno}}
+ property, which can be accessed with
+ {{(get-condition-property <the-condition-object> 'exn 'errno)}}.
+
=== Information about the program's invocation
==== argc+argv
diff --git a/port.scm b/port.scm
index 8826d13a..38dbec85 100644
--- a/port.scm
+++ b/port.scm
@@ -411,7 +411,8 @@ char *ttyname(int fd) {
(string-append string-append))
(lambda (type loc msg . args)
(let ((rn (##sys#update-errno)))
- (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args)))))
+ (apply ##sys#signal-hook/errno
+ type rn loc (string-append msg " - " (strerror rn)) args)))))
;; Terminal ports
(define (terminal-port? port)
diff --git a/posix-common.scm b/posix-common.scm
index 6f7028c3..96e4da10 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -189,7 +189,8 @@ EOF
[string-append string-append] )
(lambda (type loc msg . args)
(let ([rn (##sys#update-errno)])
- (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+ (apply ##sys#signal-hook/errno
+ type rn loc (string-append msg " - " (strerror rn)) args)))))
(define ##sys#posix-error posix-error)
diff --git a/posix.scm b/posix.scm
index a082f054..78e54065 100644
--- a/posix.scm
+++ b/posix.scm
@@ -199,8 +199,8 @@
(##sys#check-string cmd 'system)
(let ((r (##core#inline "C_execute_shell_command" cmd)))
(cond ((fx< r 0)
- (##sys#update-errno)
- (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd))
+ (##sys#signal-hook/errno
+ #:process-error (##sys#update-errno) 'system "`system' invocation failed" cmd))
(else r))))
;;; Like `system', but bombs on nonzero return code:
diff --git a/posixunix.scm b/posixunix.scm
index 213f7492..bad9b4c0 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -604,8 +604,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda (id)
(##sys#check-fixnum id 'current-user-id)
(when (fx< (##core#inline "C_setuid" id) 0)
- (##sys#update-errno)
- (##sys#error 'current-user-id!-setter "cannot set user ID" id) ) )
+ (##sys#error/errno (##sys#update-errno)
+ 'current-user-id!-setter "cannot set user ID" id)))
"(chicken.process-context.posix#current-user-id)"))
(set! chicken.process-context.posix#current-effective-user-id
@@ -614,9 +614,9 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda (id)
(##sys#check-fixnum id 'current-effective-user-id)
(when (fx< (##core#inline "C_seteuid" id) 0)
- (##sys#update-errno)
- (##sys#error
- 'effective-user-id!-setter "cannot set effective user ID" id) ) )
+ (##sys#error/errno (##sys#update-errno)
+ 'effective-user-id!-setter
+ "cannot set effective user ID" id)))
"(chicken.process-context.posix#current-effective-user-id)"))
(set! chicken.process-context.posix#current-group-id
@@ -625,8 +625,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda (id)
(##sys#check-fixnum id 'current-group-id)
(when (fx< (##core#inline "C_setgid" id) 0)
- (##sys#update-errno)
- (##sys#error 'current-group-id!-setter "cannot set group ID" id) ) )
+ (##sys#error/errno (##sys#update-errno)
+ 'current-group-id!-setter "cannot set group ID" id)))
"(chicken.process-context.posix#current-group-id)") )
(set! chicken.process-context.posix#current-effective-group-id
@@ -635,9 +635,9 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda (id)
(##sys#check-fixnum id 'current-effective-group-id)
(when (fx< (##core#inline "C_setegid" id) 0)
- (##sys#update-errno)
- (##sys#error
- 'effective-group-id!-setter "cannot set effective group ID" id) ) )
+ (##sys#error/errno (##sys#update-errno)
+ 'effective-group-id!-setter
+ "cannot set effective group ID" id)))
"(chicken.process-context.posix#current-effective-group-id)") )
(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")
@@ -697,8 +697,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda ()
(let ([a (##core#inline "C_setsid" #f)])
(when (fx< a 0)
- (##sys#update-errno)
- (##sys#error 'create-session "cannot create session") )
+ (##sys#error/errno (##sys#update-errno)
+ 'create-session "cannot create session"))
a)) )
(set! chicken.process-context.posix#process-group-id
@@ -707,15 +707,16 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#check-fixnum pid 'process-group-id)
(let ([a (##core#inline "C_getpgid" pid)])
(when (fx< a 0)
- (##sys#update-errno)
- (##sys#error 'process-group-id "cannot retrieve process group ID" pid) )
+ (##sys#error/errno (##sys#update-errno)
+ 'process-group-id
+ "cannot retrieve process group ID" pid))
a))
(lambda (pid pgid)
(##sys#check-fixnum pid 'process-group)
(##sys#check-fixnum pgid 'process-group)
(when (fx< (##core#inline "C_setpgid" pid pgid) 0)
- (##sys#update-errno)
- (##sys#error 'process-group "cannot set process group ID" pid pgid) ) )
+ (##sys#error/errno (##sys#update-errno)
+ 'process-group "cannot set process group ID" pid pgid)))
"(chicken.process-context.posix#process-group-id pid)"))
diff --git a/posixwin.scm b/posixwin.scm
index d3e607d8..cadba1b3 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -525,8 +525,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#check-fixnum mode 'file-open)
(let ([fd (##core#inline "C_open" (##sys#make-c-string filename 'file-open) flags mode)])
(when (eq? -1 fd)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'file-open "cannot open file" filename flags mode) )
+ (##sys#signal-hook/errno
+ #:file-error (##sys#update-errno) 'file-open "cannot open file" filename flags mode))
fd) ) ) ) )
(set! chicken.file.posix#file-close
@@ -548,8 +548,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
(let ([n (##core#inline "C_read" fd buf size)])
(when (eq? -1 n)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'file-read "cannot read from file" fd size) )
+ (##sys#signal-hook/errno
+ #:file-error (##sys#update-errno) 'file-read "cannot read from file" fd size))
(list buf n) ) ) ) )
(set! chicken.file.posix#file-write
@@ -561,8 +561,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#check-fixnum size 'file-write)
(let ([n (##core#inline "C_write" fd buffer size)])
(when (eq? -1 n)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'file-write "cannot write to file" fd size) )
+ (##sys#signal-hook/errno
+ #:file-error (##sys#update-errno) 'file-write "cannot write to file" fd size))
n) ) ) )
(set! chicken.file.posix#file-mkstemp
@@ -612,8 +612,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda (#!optional (mode (fxior chicken.file.posix#open/binary
chicken.file.posix#open/noinherit)))
(when (fx< (##core#inline "C_pipe" #f mode) 0)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
+ (##sys#signal-hook/errno
+ #:file-error (##sys#update-errno) 'create-pipe "cannot create pipe"))
(values _pipefd0 _pipefd1) ) )
;;; Signal processing:
@@ -676,8 +676,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#check-fixnum n 'duplicate-fileno)
(##core#inline "C_dup2" old n) ) ) ] )
(when (fx< fd 0)
- (##sys#update-errno)
- (##sys#signal-hook #:file-error 'duplicate-fileno "cannot duplicate file descriptor" old) )
+ (##sys#signal-hook/errno
+ #:file-error (##sys#update-errno) 'duplicate-fileno "cannot duplicate file descriptor" old))
fd) ) )
@@ -754,9 +754,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(or (get-environment-variable "COMSPEC")
(if (##core#inline "C_get_shlcmd")
_shlcmd
- (begin
- (##sys#update-errno)
- (##sys#error loc "cannot retrieve system directory") ) ) ) )
+ (##sys#error/errno
+ (##sys#update-errno) loc "cannot retrieve system directory"))))
(define (shell-command-arguments cmdlin)
(list "/c" cmdlin) )
@@ -820,9 +819,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
handle
(and stderrf (chicken.file.posix#open-input-file*
stderr_fd)))
- (begin
- (##sys#update-errno)
- (##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) )
+ (##sys#signal-hook/errno
+ #:process-error (##sys#update-errno) loc "cannot execute process" cmdlin))))))))
;; TODO: See if this can be moved to posix-common
(let ((%process
@@ -867,9 +865,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda ()
(if (##core#inline "C_get_user_name")
_username
- (begin
- (##sys#update-errno)
- (##sys#error 'current-user-name "cannot retrieve current user-name") ) ) ) )
+ (##sys#error/errno
+ (##sys#update-errno) 'current-user-name "cannot retrieve current user-name"))))
;;; unimplemented stuff:
diff --git a/tests/condition-tests.scm b/tests/condition-tests.scm
index 207b6231..3253fe81 100644
--- a/tests/condition-tests.scm
+++ b/tests/condition-tests.scm
@@ -32,3 +32,20 @@
(assert (equal? (condition->list condition3)
'((exn message "foo" arguments ("bar") location test)
(sam age 23 partner "max"))))
+
+;; testing errno in condition objects
+
+(import (chicken errno)
+ (chicken file)
+ (chicken process-context))
+
+(let ((nonexistent-path "this/path/does/not/exist/,hopefully"))
+ (assert (not (file-exists? nonexistent-path)))
+
+ (handle-exceptions exn
+ (assert (= (get-condition-property exn 'exn 'errno) errno/noent))
+ (delete-file nonexistent-path))
+
+ (handle-exceptions exn
+ (assert (= (get-condition-property exn 'exn 'errno) errno/noent))
+ (change-directory nonexistent-path)))
Trap