1;;;
2;;; srfi-1981 - POSIX system call exceptions
3;;;
4;;;   Copyright (c) 2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34;; Gauche traditionally used <system-error> for system call exceptions.
35;; srfi-198 adds a few fields that are not in <system-error>.  So we use
36;; compound condition for that.   Note that syscall-error? responds #t
37;; to a bare <system-error> as well, for the interoperability.
38;; We may integrate those extra slots to <system-error> eventually, so
39;; do not rely on this internal arrangement.
40
41(define-module srfi-198
42  (export make-syscall-error
43          syscall-error?
44          syscall-error:errno
45          syscall-error:message
46          syscall-error:procedure-name
47          syscall-error:syscall-name
48          syscall-error:data
49          errno-error))
50(select-module srfi-198)
51
52(define-condition-type <syscall-error-mixin> <condition>
53  #f
54  (procedure-name)
55  (syscall-name)
56  (data))
57
58(define (make-syscall-error errno message procedure-name syscall-name data)
59  (condition (<system-error>
60              (errno errno)
61              (message message))
62             (<syscall-error-mixin>
63              (procedure-name procedure-name)
64              (syscall-name syscall-name)
65              (data data))))
66
67(define (syscall-error? x) (condition-has-type? x <system-error>))
68
69(define (syscall-error:errno x)
70  (assume (syscall-error? x))
71  (condition-ref x 'errno))
72
73(define (syscall-error:message x)
74  (assume (syscall-error? x))
75  (condition-ref x 'message))
76
77(define (syscall-error:procedure-name x)
78  (assume (syscall-error? x))
79  (if (condition-has-type? x <syscall-error-mixin>)
80    (condition-ref x 'procedure-name)
81    'unknown))
82
83(define (syscall-error:syscall-name x)
84  (assume (syscall-error? x))
85  (if (condition-has-type? x <syscall-error-mixin>)
86    (condition-ref x 'syscall-name)
87    'unknown))
88
89(define (syscall-error:data x)
90  (assume (syscall-error? x))
91  (if (condition-has-type? x <syscall-error-mixin>)
92    (condition-ref x 'data)
93    '()))
94
95(define (errno-error errno procedure-name syscall-name . objs)
96  (raise (make-syscall-error errno
97                             (sys-strerror errno)
98                             procedure-name
99                             syscall-name
100                             objs)))
101