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 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)))
  37
  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
  42     (case base-type
  43       (:string
  44        (setf error-predicate '(lambda (s) (not (stringp s)))))
  45       (t
  46        (case (cffi::canonicalize-foreign-type base-type)
  47          (:pointer
  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))
  55          (t
  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
  61                  :base-type base-type
  62                  :error-predicate error-predicate
  63                  :return-filter return-filter
  64                  :error-generator error-generator))
  65
  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)))
  72       value
  73       (with-gensyms (block)
  74         `(block ,block
  75            (tagbody :restart
  76               (let ((r (convert-from-foreign ,value ',(base-type-of type))))
  77                 ,(let ((return-exp
  78                         (if (eql 'identity (return-filter-of type))
  79                             'r
  80                             `(,(return-filter-of type) r))))
  81                       `(return-from ,block
  82                          ,(if (eql 'never-fails (error-predicate-of type))
  83                               `return-exp
  84                               `(if (,(error-predicate-of type) r)
  85                                    (,(error-generator-of type) r)
  86                                    ,return-exp))))))))))
  87 \f
  88
  89 (defmacro defentrypoint (name (&rest args) &body body)
  90   `(progn
  91      (declaim (inline ,name))
  92      (defun ,name ,args ,@body)))
  93
  94 (defmacro defcfun* (name-and-opts return-type &body args)
  95   (multiple-value-bind (lisp-name c-name options)
  96       (cffi::parse-name-and-options name-and-opts)
  97     `(progn
  98        (declaim (inline ,lisp-name))
  99        (defcfun (,c-name ,lisp-name ,@options) ,return-type
 100          ,@args))))
 101
 102 (defmacro signal-posix-error/restart (ret)
 103   `(if (= eintr (get-errno))
 104        (go :restart)
 105        (signal-posix-error ,ret)))
 106
 107 (defmacro defsyscall (name-and-opts return-type &body args)
 108   (multiple-value-bind (lisp-name c-name options)
 109       (cffi::parse-name-and-options name-and-opts)
 110     `(progn
 111        (declaim (inline ,lisp-name))
 112        (defcfun (,c-name ,lisp-name ,@options)
 113            (return-wrapper ,return-type :error-generator signal-posix-error)
 114          ,@args))))
 115
 116 (defmacro defsyscall* (name-and-opts return-type &body args)
 117   (multiple-value-bind (lisp-name c-name options)
 118       (cffi::parse-name-and-options name-and-opts)
 119     `(progn
 120        (declaim (inline ,lisp-name))
 121        (defcfun (,c-name ,lisp-name ,@options)
 122            (return-wrapper ,return-type :error-generator signal-posix-error/restart)
 123          ,@args))))