1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Early definitions.
6 (in-package :iolib.syscalls
)
8 ;;;; Sizes of Standard Types
10 (defconstant size-of-char
(foreign-type-size :char
))
11 (defconstant size-of-int
(foreign-type-size :int
))
12 (defconstant size-of-long
(foreign-type-size :long
))
13 (defconstant size-of-long-long
(foreign-type-size :long-long
))
14 (defconstant size-of-pointer
(foreign-type-size :pointer
))
15 (defconstant size-of-short
(foreign-type-size :short
))
18 ;;; Error predicate that always returns NIL. Not actually used
19 ;;; because the RETURN-WRAPPER optimizes this call away.
20 (defun never-fails (errcode)
21 (declare (ignore errcode
))
24 ;;; NOTE: This is a pretty neat type that probably deserves to be
25 ;;; included in CFFI. --luis
27 ;;; This type is used by DEFSYSCALL to automatically check for errors
28 ;;; using the ERROR-PREDICATE function which is passed the foreign
29 ;;; function's return value (after going through RETURN-FILTER). If
30 ;;; ERROR-PREDICATE returns true, ERROR-GENERATOR is invoked. See the
31 ;;; RETURN-WRAPPER parse method and type translation.
32 (define-foreign-type return-wrapper
()
33 ((error-predicate :initarg
:error-predicate
:reader error-predicate-of
)
34 (return-filter :initarg
:return-filter
:reader return-filter-of
)
35 (error-generator :initarg
:error-generator
:reader error-generator-of
)
36 (base-type :initarg
:base-type
:reader base-type-of
)))
38 (define-parse-method return-wrapper
39 (base-type &key error-predicate
(return-filter 'identity
) error-generator
)
40 ;; pick a default error-predicate
41 (unless error-predicate
44 (setf error-predicate
'(lambda (s) (not (stringp s
)))))
46 (case (cffi::canonicalize-foreign-type base-type
)
48 (setf error-predicate
'null-pointer-p
))
49 ((:char
:short
:int
:long
:long-long
)
50 (setf error-predicate
'minusp
))
51 ;; FIXME: go here if the canonical type is unsigned.
52 ((:unsigned-char
:unsigned-short
:unsigned-int
53 :unsigned-long
:unsigned-long-long
:void
)
54 (setf error-predicate
'never-fails
))
56 (error "Could not choose an error-predicate function."))))))
57 (unless (or (eql 'never-fails error-predicate
) error-generator
)
58 (error "Function can fail but no error-generator suplied."))
59 (make-instance 'return-wrapper
60 :actual-type base-type
62 :error-predicate error-predicate
63 :return-filter return-filter
64 :error-generator error-generator
))
66 ;;; This type translator sets up the appropriate calls to
67 ;;; RETURN-FILTER, ERROR-PREDICATE and ERROR-GENERATOR around the
68 ;;; foreign function call.
69 (defmethod expand-from-foreign (value (type return-wrapper
))
70 (if (and (eql 'identity
(return-filter-of type
))
71 (eql 'never-fails
(error-predicate-of type
)))
76 (let ((r (convert-from-foreign ,value
',(base-type-of type
))))
78 (if (eql 'identity
(return-filter-of type
))
80 `(,(return-filter-of type
) r
))))
82 ,(if (eql 'never-fails
(error-predicate-of type
))
84 `(if (,(error-predicate-of type
) r
)
85 (,(error-generator-of type
) r
)
89 (defun foreign-name (spec &optional varp
)
90 (declare (ignore varp
))
91 (check-type spec list
)
92 (destructuring-bind (first second
) spec
95 (foreign-name (list second
(ensure-list first
))))
97 (setf second
(ensure-list second
))
98 (assert (every #'stringp second
))
99 (loop :for sym
:in second
100 :if
(foreign-symbol-pointer sym
) :do
(return sym
)
102 (error "None of these foreign symbols is defined: ~{~S~^, ~}"
105 (defun parse-name-and-options (spec &optional varp
)
106 (values (cffi::lisp-name spec varp
)
107 (foreign-name spec varp
)
108 (cffi::foreign-options spec varp
)))
111 (defmacro defentrypoint
(name (&rest args
) &body body
)
113 (declaim (inline ,name
))
114 (defun ,name
,args
,@body
)))
116 (defmacro defcfun
* (name-and-opts return-type
&body args
)
117 (multiple-value-bind (lisp-name c-name options
)
118 (parse-name-and-options name-and-opts
)
120 (declaim (inline ,lisp-name
))
121 (defcfun (,c-name
,lisp-name
,@options
) ,return-type
124 (defmacro signal-posix-error
/restart
(ret)
125 `(if (= eintr
(%sys-errno
))
127 (signal-posix-error ,ret
)))
129 (defmacro defsyscall
(name-and-opts return-type
&body args
)
130 (multiple-value-bind (lisp-name c-name options
)
131 (parse-name-and-options name-and-opts
)
133 (declaim (inline ,lisp-name
))
134 (defcfun (,c-name
,lisp-name
,@options
)
135 (return-wrapper ,return-type
:error-generator signal-posix-error
)
138 (defmacro defsyscall
* (name-and-opts return-type
&body args
)
139 (multiple-value-bind (lisp-name c-name options
)
140 (parse-name-and-options name-and-opts
)
142 (declaim (inline ,lisp-name
))
143 (defcfun (,c-name
,lisp-name
,@options
)
144 (return-wrapper ,return-type
:error-generator signal-posix-error
/restart
)