src/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    (handle2 :initarg :handle2 :reader handle2-of)
  40    (base-type :initarg :base-type :reader base-type-of)))
  41
  42 (defun default-error-predicate (base-type)
  43   (case base-type
  44     (:string
  45      '(lambda (s) (not (stringp s))))
  46     (t
  47      (case (cffi::canonicalize-foreign-type base-type)
  48        (:pointer
  49         'null-pointer-p)
  50        ((:char :short :int :long :long-long)
  51         'minusp)
  52        ;; FIXME: go here if the canonical type is unsigned.
  53        ((:unsigned-char :unsigned-short :unsigned-int
  54                         :unsigned-long :unsigned-long-long :void)
  55         'never-fails)
  56        (t
  57         (error "Could not choose an error-predicate function."))))))
  58
  59 (define-parse-method syscall-wrapper
  60     (base-type &key handle handle2 (restart nil restart-p)
  61      (error-predicate 'never-fails error-predicate-p)
  62      (error-location :errno)
  63      (return-filter 'identity)
  64      (error-generator 'signal-syscall-error))
  65   ;; pick a default error-predicate
  66   (unless error-predicate-p
  67     (setf error-predicate (default-error-predicate base-type)))
  68   (when (and (not restart-p) (eql 't restart))
  69     (setf error-generator 'signal-syscall-error/restart))
  70   (unless (or (eql 'never-fails error-predicate) error-generator)
  71     (error "Function can fail but no error-generator suplied."))
  72   (make-instance 'syscall-wrapper
  73                  :actual-type base-type
  74                  :base-type base-type
  75                  :handle handle
  76                  :handle2 handle2
  77                  :restart restart
  78                  :error-predicate error-predicate
  79                  :error-location error-location
  80                  :return-filter return-filter
  81                  :error-generator error-generator))
  82
  83 ;;; This type translator sets up the appropriate calls to
  84 ;;; RETURN-FILTER, ERROR-PREDICATE and ERROR-GENERATOR around the
  85 ;;; foreign function call.
  86 (defmethod expand-from-foreign (value (type syscall-wrapper))
  87   (if (and (eql 'identity (return-filter-of type))
  88            (eql 'never-fails (error-predicate-of type)))
  89       value
  90       (with-gensyms (retval errno block)
  91         (let ((foreign-call
  92                `(let* ,(remove-if 'null
  93                                   `((,retval (convert-from-foreign ,value ',(base-type-of type)))
  94                                     ,(case (error-location-of type)
  95                                            (:errno `(,errno (%sys-errno)))
  96                                            (:return `(,errno ,retval)))))
  97                   ,(let* ((return-val-exp
  98                            (if (eql 'identity (return-filter-of type))
  99                                retval
 100                                `(,(return-filter-of type) ,retval)))
 101                           (return-exp
 102                            (if (eql 'never-fails (error-predicate-of type))
 103                                `return-val-exp
 104                                `(if (,(error-predicate-of type) ,retval)
 105                                     (,(error-generator-of type) ,errno
 106                                       ,(handle-of type) ,(handle2-of type))
 107                                     ,return-val-exp))))
 108                          (if (syscall-restart-p type)
 109                              `(return-from ,block ,return-exp)
 110                              return-exp)))))
 111           (if (syscall-restart-p type)
 112               `(block ,block
 113                  (tagbody :restart
 114                     ,foreign-call))
 115               foreign-call)))))
 116
 117 (defmacro signal-syscall-error/restart (errno)
 118   `(if (= eintr ,errno)
 119        (go :restart)
 120        (signal-syscall-error ,errno)))
 121 \f
 122
 123 (defun foreign-name (spec &optional varp)
 124   (declare (ignore varp))
 125   (check-type spec list)
 126   (destructuring-bind (first second) spec
 127     (etypecase first
 128       ((or string cons)
 129        (foreign-name (list second (ensure-list first))))
 130       (symbol
 131        (setf second (ensure-list second))
 132        (assert (every #'stringp second))
 133        (loop :for sym :in second
 134              :if (foreign-symbol-pointer sym) :do (return sym)
 135              :finally
 136              (error "None of these foreign symbols is defined: ~{~S~^, ~}"
 137                     second))))))
 138
 139 (defun parse-name-and-options (spec &optional varp)
 140   (values (cffi::lisp-name spec varp)
 141           (foreign-name spec varp)
 142           (cffi::foreign-options spec varp)))
 143 \f
 144
 145 (defmacro defentrypoint (name (&rest args) &body body)
 146   `(progn
 147      (declaim (inline ,name))
 148      (defun ,name ,args ,@body)))
 149
 150 (defmacro defcfun* (name-and-opts return-type &body args)
 151   (multiple-value-bind (lisp-name c-name options)
 152       (parse-name-and-options name-and-opts)
 153     `(progn
 154        (declaim (inline ,lisp-name))
 155        (defcfun (,c-name ,lisp-name ,@options) ,return-type
 156          ,@args))))
 157
 158 (defmacro defsyscall (name-and-opts return-type &body args)
 159   (multiple-value-bind (lisp-name c-name options)
 160       (parse-name-and-options name-and-opts)
 161     `(progn
 162        (declaim (inline ,lisp-name))
 163        (defcfun (,c-name ,lisp-name ,@options)
 164            (syscall-wrapper ,@(ensure-list return-type))
 165          ,@args))))