src/syscalls/early.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Early FFI definitions.
   4 ;;;
   5
   6 (in-package :iolib.syscalls)
   7
   8 ;;;-------------------------------------------------------------------------
   9 ;;; Syscall return wrapper
  10 ;;;-------------------------------------------------------------------------
  11
  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))
  16   nil)
  17
  18 ;;; NOTE: This is a pretty neat type that probably deserves to be
  19 ;;; included in CFFI. --luis
  20 ;;;
  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)))
  36
  37 (defun default-error-predicate (base-type)
  38   (case base-type
  39     (sstring
  40      '(lambda (s) (null s)))
  41     (:string
  42      '(lambda (s) (not (stringp s))))
  43     (t
  44      (case (cffi::canonicalize-foreign-type base-type)
  45        (:pointer
  46         'null-pointer-p)
  47        ((:char :short :int :long :long-long)
  48         'minusp)
  49        ;; FIXME: go here if the canonical type is unsigned.
  50        ((:unsigned-char :unsigned-short :unsigned-int
  51                         :unsigned-long :unsigned-long-long :void)
  52         'never-fails)
  53        (t
  54         (error "Could not choose an error-predicate function."))))))
  55
  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)))
  65   (when restart
  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
  70                  :syscall syscall
  71                  :actual-type base-type
  72                  :base-type base-type
  73                  :handle handle
  74                  :handle2 handle2
  75                  :restart restart
  76                  :error-predicate error-predicate
  77                  :error-location error-location
  78                  :return-filter return-filter
  79                  :error-generator error-generator))
  80
  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)))
  87       value
  88       (with-gensyms (retval errno block)
  89         (let ((foreign-call
  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))
  97                                retval
  98                                `(,(return-filter-of type) ,retval)))
  99                           (return-exp
 100                            (if (eql 'never-fails (error-predicate-of type))
 101                                `return-val-exp
 102                                `(if (,(error-predicate-of type) ,retval)
 103                                     (,(error-generator-of type) ,errno ,(syscall-of type)
 104                                       ,(handle-of type) ,(handle2-of type))
 105                                     ,return-val-exp))))
 106                          (if (syscall-restart-p type)
 107                              `(return-from ,block ,return-exp)
 108                              return-exp)))))
 109           (if (syscall-restart-p type)
 110               `(block ,block
 111                  (tagbody :restart
 112                     ,foreign-call))
 113               foreign-call)))))
 114
 115 (defmacro signal-syscall-error/restart (errno &optional syscall fd fd2)
 116   `(if (= eintr ,errno)
 117        (go :restart)
 118        (signal-syscall-error ,errno ,syscall ,fd ,fd2)))
 119 \f
 120
 121 ;;;-------------------------------------------------------------------------
 122 ;;; Syscall definers
 123 ;;;-------------------------------------------------------------------------
 124
 125 (defmacro defentrypoint (name (&rest args) &body body)
 126   `(progn
 127      (declaim (inline ,name))
 128      (defun ,name ,args ,@body)))
 129
 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)
 133     `(progn
 134        (declaim (inline ,lisp-name))
 135        (defcfun (,c-name ,lisp-name ,@options) ,return-type
 136          ,@args))))
 137
 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)
 141     `(progn
 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)))
 146          ,@args))))
 147 \f
 148 ;;;-------------------------------------------------------------------------
 149 ;;; CFFI additions
 150 ;;;-------------------------------------------------------------------------
 151
 152 (defalias (function sizeof) cffi:foreign-type-size)
 153
 154 (deffoldable sizeof (t) t)