syscalls/early.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Early definitions.
   4 ;;;
   5
   6 (in-package :iolib.syscalls)
   7
   8 ;;;; Sizes of Standard Types
   9
  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))
  16 \f
  17
  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))
  22   nil)
  23
  24 ;;; NOTE: This is a pretty neat type that probably deserves to be
  25 ;;; included in CFFI. --luis
  26 ;;;
  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 syscall-wrapper ()
  33   ((error-predicate :initarg :error-predicate :reader error-predicate-of)
  34    (error-location :initarg :error-location :reader error-location-of)
  35    (return-filter :initarg :return-filter :reader return-filter-of)
  36    (error-generator :initarg :error-generator :reader error-generator-of)
  37    (restart :initarg :restart :reader syscall-restart-p)
  38    (handle :initarg :handle :reader handle-of)
  39    (base-type :initarg :base-type :reader base-type-of)))
  40
  41 (defun default-error-predicate (base-type)
  42   (case base-type
  43     (:string
  44      '(lambda (s) (not (stringp s))))
  45     (t
  46      (case (cffi::canonicalize-foreign-type base-type)
  47        (:pointer
  48         'null-pointer-p)
  49        ((:char :short :int :long :long-long)
  50         '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         'never-fails)
  55        (t
  56         (error "Could not choose an error-predicate function."))))))
  57
  58 (define-parse-method syscall-wrapper
  59     (base-type &key handle (restart nil restart-p)
  60      (error-predicate 'never-fails error-predicate-p)
  61      (error-location :errno)
  62      (return-filter 'identity)
  63      (error-generator 'signal-posix-error))
  64   ;; pick a default error-predicate
  65   (unless error-predicate-p
  66     (setf error-predicate (default-error-predicate base-type)))
  67   (when (and (not restart-p) (eql 't restart))
  68     (setf error-generator 'signal-posix-error/restart))
  69   (unless (or (eql 'never-fails error-predicate) error-generator)
  70     (error "Function can fail but no error-generator suplied."))
  71   (make-instance 'syscall-wrapper
  72                  :actual-type base-type
  73                  :base-type base-type
  74                  :handle handle
  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 (%sys-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 ,(handle-of type))
 104                                     ,return-val-exp))))
 105                          (if (syscall-restart-p type)
 106                              `(return-from ,block ,return-exp)
 107                              return-exp)))))
 108           (if (syscall-restart-p type)
 109               `(block ,block
 110                  (tagbody :restart
 111                     ,foreign-call))
 112               foreign-call)))))
 113
 114 (defmacro signal-posix-error/restart (errno)
 115   `(if (= eintr ,errno)
 116        (go :restart)
 117        (signal-posix-error ,errno)))
 118 \f
 119
 120 (defun foreign-name (spec &optional varp)
 121   (declare (ignore varp))
 122   (check-type spec list)
 123   (destructuring-bind (first second) spec
 124     (etypecase first
 125       ((or string cons)
 126        (foreign-name (list second (ensure-list first))))
 127       (symbol
 128        (setf second (ensure-list second))
 129        (assert (every #'stringp second))
 130        (loop :for sym :in second
 131              :if (foreign-symbol-pointer sym) :do (return sym)
 132              :finally
 133              (error "None of these foreign symbols is defined: ~{~S~^, ~}"
 134                     second))))))
 135
 136 (defun parse-name-and-options (spec &optional varp)
 137   (values (cffi::lisp-name spec varp)
 138           (foreign-name spec varp)
 139           (cffi::foreign-options spec varp)))
 140 \f
 141
 142 (defmacro defentrypoint (name (&rest args) &body body)
 143   `(progn
 144      (declaim (inline ,name))
 145      (defun ,name ,args ,@body)))
 146
 147 (defmacro defcfun* (name-and-opts return-type &body args)
 148   (multiple-value-bind (lisp-name c-name options)
 149       (parse-name-and-options name-and-opts)
 150     `(progn
 151        (declaim (inline ,lisp-name))
 152        (defcfun (,c-name ,lisp-name ,@options) ,return-type
 153          ,@args))))
 154
 155 (defmacro defsyscall (name-and-opts return-type &body args)
 156   (multiple-value-bind (lisp-name c-name options)
 157       (parse-name-and-options name-and-opts)
 158     `(progn
 159        (declaim (inline ,lisp-name))
 160        (defcfun (,c-name ,lisp-name ,@options)
 161            (syscall-wrapper ,@(ensure-list return-type))
 162          ,@args))))