1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Early FFI definitions.
6 (in-package :iolib.syscalls
)
8 ;;;-------------------------------------------------------------------------
9 ;;; Syscall return wrapper
10 ;;;-------------------------------------------------------------------------
12 ;;; Error predicate that always returns NIL. Not actually used
13 ;;; because the RETURN-WRAPPER optimizes this call away.
14 (defun never-fails (errcode syscall
)
15 (declare (ignore errcode syscall
))
18 ;;; NOTE: This is a pretty neat type that probably deserves to be
19 ;;; included in CFFI. --luis
21 ;;; This type is used by DEFSYSCALL to automatically check for errors
22 ;;; using the ERROR-PREDICATE function which is passed the foreign
23 ;;; function's return value (after going through RETURN-FILTER). If
24 ;;; ERROR-PREDICATE returns true, ERROR-GENERATOR is invoked. See the
25 ;;; RETURN-WRAPPER parse method and type translation.
26 (define-foreign-type syscall-wrapper
()
27 ((syscall :initarg
:syscall
:reader syscall-of
)
28 (error-predicate :initarg
:error-predicate
:reader error-predicate-of
)
29 (error-location :initarg
:error-location
:reader error-location-of
)
30 (return-filter :initarg
:return-filter
:reader return-filter-of
)
31 (error-generator :initarg
:error-generator
:reader error-generator-of
)
32 (restart :initarg
:restart
:reader syscall-restart-p
)
33 (handle :initarg
:handle
:reader handle-of
)
34 (handle2 :initarg
:handle2
:reader handle2-of
)
35 (base-type :initarg
:base-type
:reader base-type-of
)))
37 (defun default-error-predicate (base-type)
40 '(lambda (s) (null s
)))
42 '(lambda (s) (not (stringp s
))))
44 (case (cffi::canonicalize-foreign-type base-type
)
47 ((:char
:short
:int
:long
:long-long
)
49 ;; FIXME: go here if the canonical type is unsigned.
50 ((:unsigned-char
:unsigned-short
:unsigned-int
51 :unsigned-long
:unsigned-long-long
:void
)
54 (error "Could not choose an error-predicate function."))))))
56 (define-parse-method syscall-wrapper
57 (base-type &key syscall handle handle2 restart
58 (error-predicate 'never-fails error-predicate-p
)
59 (error-location :errno
)
60 (return-filter 'identity
)
61 (error-generator 'signal-syscall-error
))
62 ;; pick a default error-predicate
63 (unless error-predicate-p
64 (setf error-predicate
(default-error-predicate base-type
)))
66 (setf error-generator
'signal-syscall-error
/restart
))
67 (unless (or (eql 'never-fails error-predicate
) error-generator
)
68 (error "Function can fail but no error-generator suplied."))
69 (make-instance 'syscall-wrapper
71 :actual-type base-type
76 :error-predicate error-predicate
77 :error-location error-location
78 :return-filter return-filter
79 :error-generator error-generator
))
81 ;;; This type translator sets up the appropriate calls to
82 ;;; RETURN-FILTER, ERROR-PREDICATE and ERROR-GENERATOR around the
83 ;;; foreign function call.
84 (defmethod expand-from-foreign (value (type syscall-wrapper
))
85 (if (and (eql 'identity
(return-filter-of type
))
86 (eql 'never-fails
(error-predicate-of type
)))
88 (with-gensyms (retval errno block
)
90 `(let* ,(remove-if 'null
91 `((,retval
(convert-from-foreign ,value
',(base-type-of type
)))
92 ,(case (error-location-of type
)
93 (:errno
`(,errno
(errno)))
94 (:return
`(,errno
,retval
)))))
95 ,(let* ((return-val-exp
96 (if (eql 'identity
(return-filter-of type
))
98 `(,(return-filter-of type
) ,retval
)))
100 (if (eql 'never-fails
(error-predicate-of type
))
102 `(if (,(error-predicate-of type
) ,retval
)
103 (,(error-generator-of type
) ,errno
,(syscall-of type
)
104 ,(handle-of type
) ,(handle2-of type
))
106 (if (syscall-restart-p type
)
107 `(return-from ,block
,return-exp
)
109 (if (syscall-restart-p type
)
115 (defmacro signal-syscall-error
/restart
(errno &optional syscall fd fd2
)
116 `(if (= eintr
,errno
)
118 (signal-syscall-error ,errno
,syscall
,fd
,fd2
)))
121 ;;;-------------------------------------------------------------------------
123 ;;;-------------------------------------------------------------------------
125 (defmacro defentrypoint
(name (&rest args
) &body body
)
127 (declaim (inline ,name
))
128 (defun ,name
,args
,@body
)))
130 (defmacro defcfun
* (name-and-opts return-type
&body args
)
131 (multiple-value-bind (lisp-name c-name options
)
132 (cffi::parse-name-and-options name-and-opts
)
134 (declaim (inline ,lisp-name
))
135 (defcfun (,c-name
,lisp-name
,@options
) ,return-type
138 (defmacro defsyscall
(name-and-opts return-type
&body args
)
139 (multiple-value-bind (lisp-name c-name options
)
140 (cffi::parse-name-and-options name-and-opts
)
142 (declaim (inline ,lisp-name
))
143 (defcfun (,c-name
,lisp-name
,@options
)
144 (syscall-wrapper ,@(append (ensure-list return-type
)
145 (list :syscall c-name
)))
148 ;;;-------------------------------------------------------------------------
150 ;;;-------------------------------------------------------------------------
152 (defalias (function sizeof
) cffi
:foreign-type-size
)
154 (deffoldable sizeof
(t) t
)