src/syscalls/early.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Early FFI definitions.
   4 ;;;
   5
   6 (in-package :iolib.syscalls)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Sizes of Standard Types
  10 ;;;-------------------------------------------------------------------------
  11
  12 (defconstant size-of-char (foreign-type-size :char))
  13 (defconstant size-of-int (foreign-type-size :int))
  14 (defconstant size-of-long (foreign-type-size :long))
  15 (defconstant size-of-long-long (foreign-type-size :long-long))
  16 (defconstant size-of-pointer (foreign-type-size :pointer))
  17 (defconstant size-of-short (foreign-type-size :short))
  18 \f
  19
  20 ;;;-------------------------------------------------------------------------
  21 ;;; Syscall return wrapper
  22 ;;;-------------------------------------------------------------------------
  23
  24 ;;; Error predicate that always returns NIL.  Not actually used
  25 ;;; because the RETURN-WRAPPER optimizes this call away.
  26 (defun never-fails (errcode syscall)
  27   (declare (ignore errcode syscall))
  28   nil)
  29
  30 ;;; NOTE: This is a pretty neat type that probably deserves to be
  31 ;;; included in CFFI. --luis
  32 ;;;
  33 ;;; This type is used by DEFSYSCALL to automatically check for errors
  34 ;;; using the ERROR-PREDICATE function which is passed the foreign
  35 ;;; function's return value (after going through RETURN-FILTER).  If
  36 ;;; ERROR-PREDICATE returns true, ERROR-GENERATOR is invoked.  See the
  37 ;;; RETURN-WRAPPER parse method and type translation.
  38 (define-foreign-type syscall-wrapper ()
  39   ((syscall :initarg :syscall :reader syscall-of)
  40    (error-predicate :initarg :error-predicate :reader error-predicate-of)
  41    (error-location :initarg :error-location :reader error-location-of)
  42    (return-filter :initarg :return-filter :reader return-filter-of)
  43    (error-generator :initarg :error-generator :reader error-generator-of)
  44    (restart :initarg :restart :reader syscall-restart-p)
  45    (handle :initarg :handle :reader handle-of)
  46    (handle2 :initarg :handle2 :reader handle2-of)
  47    (base-type :initarg :base-type :reader base-type-of)))
  48
  49 (defun default-error-predicate (base-type)
  50   (case base-type
  51     (sstring
  52      '(lambda (s) (null s)))
  53     (:string
  54      '(lambda (s) (not (stringp s))))
  55     (t
  56      (case (cffi::canonicalize-foreign-type base-type)
  57        (:pointer
  58         'null-pointer-p)
  59        ((:char :short :int :long :long-long)
  60         'minusp)
  61        ;; FIXME: go here if the canonical type is unsigned.
  62        ((:unsigned-char :unsigned-short :unsigned-int
  63                         :unsigned-long :unsigned-long-long :void)
  64         'never-fails)
  65        (t
  66         (error "Could not choose an error-predicate function."))))))
  67
  68 (define-parse-method syscall-wrapper
  69     (base-type &key syscall handle handle2 restart
  70      (error-predicate 'never-fails error-predicate-p)
  71      (error-location :errno)
  72      (return-filter 'identity)
  73      (error-generator 'signal-syscall-error))
  74   ;; pick a default error-predicate
  75   (unless error-predicate-p
  76     (setf error-predicate (default-error-predicate base-type)))
  77   (when restart
  78     (setf error-generator 'signal-syscall-error/restart))
  79   (unless (or (eql 'never-fails error-predicate) error-generator)
  80     (error "Function can fail but no error-generator suplied."))
  81   (make-instance 'syscall-wrapper
  82                  :syscall syscall
  83                  :actual-type base-type
  84                  :base-type base-type
  85                  :handle handle
  86                  :handle2 handle2
  87                  :restart restart
  88                  :error-predicate error-predicate
  89                  :error-location error-location
  90                  :return-filter return-filter
  91                  :error-generator error-generator))
  92
  93 ;;; This type translator sets up the appropriate calls to
  94 ;;; RETURN-FILTER, ERROR-PREDICATE and ERROR-GENERATOR around the
  95 ;;; foreign function call.
  96 (defmethod expand-from-foreign (value (type syscall-wrapper))
  97   (if (and (eql 'identity (return-filter-of type))
  98            (eql 'never-fails (error-predicate-of type)))
  99       value
 100       (with-gensyms (retval errno block)
 101         (let ((foreign-call
 102                `(let* ,(remove-if 'null
 103                                   `((,retval (convert-from-foreign ,value ',(base-type-of type)))
 104                                     ,(case (error-location-of type)
 105                                            (:errno `(,errno (errno)))
 106                                            (:return `(,errno ,retval)))))
 107                   ,(let* ((return-val-exp
 108                            (if (eql 'identity (return-filter-of type))
 109                                retval
 110                                `(,(return-filter-of type) ,retval)))
 111                           (return-exp
 112                            (if (eql 'never-fails (error-predicate-of type))
 113                                `return-val-exp
 114                                `(if (,(error-predicate-of type) ,retval)
 115                                     (,(error-generator-of type) ,errno ,(syscall-of type)
 116                                       ,(handle-of type) ,(handle2-of type))
 117                                     ,return-val-exp))))
 118                          (if (syscall-restart-p type)
 119                              `(return-from ,block ,return-exp)
 120                              return-exp)))))
 121           (if (syscall-restart-p type)
 122               `(block ,block
 123                  (tagbody :restart
 124                     ,foreign-call))
 125               foreign-call)))))
 126
 127 (defmacro signal-syscall-error/restart (errno &optional syscall fd fd2)
 128   `(if (= eintr ,errno)
 129        (go :restart)
 130        (signal-syscall-error ,errno ,syscall ,fd ,fd2)))
 131 \f
 132
 133 ;;;-------------------------------------------------------------------------
 134 ;;; Utilities
 135 ;;;-------------------------------------------------------------------------
 136
 137 (defun foreign-name (spec &optional varp)
 138   (declare (ignore varp))
 139   (check-type spec list)
 140   (destructuring-bind (first second) spec
 141     (etypecase first
 142       ((or string cons)
 143        (foreign-name (list second (ensure-list first))))
 144       (symbol
 145        (setf second (ensure-list second))
 146        (assert (every #'stringp second))
 147        (loop :for sym :in second
 148              :if (foreign-symbol-pointer sym) :do (return sym)
 149              :finally
 150              (error "None of these foreign symbols is defined: ~{~S~^, ~}"
 151                     second))))))
 152
 153 (defun parse-name-and-options (spec &optional varp)
 154   (values (cffi::lisp-name spec varp)
 155           (foreign-name spec varp)
 156           (cffi::foreign-options spec varp)))
 157 \f
 158
 159 ;;;-------------------------------------------------------------------------
 160 ;;; Syscall definers
 161 ;;;-------------------------------------------------------------------------
 162
 163 (defmacro defentrypoint (name (&rest args) &body body)
 164   `(progn
 165      (declaim (inline ,name))
 166      (defun ,name ,args ,@body)))
 167
 168 (defmacro defcfun* (name-and-opts return-type &body args)
 169   (multiple-value-bind (lisp-name c-name options)
 170       (parse-name-and-options name-and-opts)
 171     `(progn
 172        (declaim (inline ,lisp-name))
 173        (defcfun (,c-name ,lisp-name ,@options) ,return-type
 174          ,@args))))
 175
 176 (defmacro defsyscall (name-and-opts return-type &body args)
 177   (multiple-value-bind (lisp-name c-name options)
 178       (parse-name-and-options name-and-opts)
 179     `(progn
 180        (declaim (inline ,lisp-name))
 181        (defcfun (,c-name ,lisp-name ,@options)
 182            (syscall-wrapper ,@(append (ensure-list return-type)
 183                                       (list :syscall c-name)))
 184          ,@args))))