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       `(tagbody :restart
  74           (let ((r (convert-from-foreign ,value ',(base-type-of type))))
  75             ,(let ((return-exp
  76                     (if (eql 'identity (return-filter-of type))
  77                         'r
  78                         `(,(return-filter-of type) r))))
  79                   (if (eql 'never-fails (error-predicate-of type))
  80                       return-exp
  81                       `(if (,(error-predicate-of type) r)
  82                            (,(error-generator-of type) r)
  83                            ,return-exp)))))))
  84 \f
  85
  86 (defmacro defentrypoint (name (&rest args) &body body)
  87   `(progn
  88      (declaim (inline ,name))
  89      (defun ,name ,args ,@body)))
  90
  91 (defmacro defcfun* (name-and-opts return-type &body args)
  92   (multiple-value-bind (lisp-name c-name options)
  93       (cffi::parse-name-and-options name-and-opts)
  94     `(progn
  95        (declaim (inline ,lisp-name))
  96        (defcfun (,c-name ,lisp-name ,@options) ,return-type
  97          ,@args))))
  98
  99 (defmacro signal-posix-error/restart (ret)
 100   `(if (= eintr (get-errno))
 101        (go :restart)
 102        (signal-posix-error ,ret)))
 103
 104 (defmacro return-posix-error/restart (ret)
 105   `(if (= eintr (get-errno))
 106        (go :restart)
 107        ,ret))
 108
 109 (defmacro defsyscall (name-and-opts return-type &body args)
 110   `(defcfun* ,name-and-opts ,return-type ,@args))
 111
 112 (defmacro defsyscall* (name-and-opts return-type &body args)
 113   (multiple-value-bind (lisp-name c-name options)
 114       (cffi::parse-name-and-options name-and-opts)
 115     `(progn
 116        (declaim (inline ,lisp-name))
 117        (defcfun (,c-name ,lisp-name ,@options)
 118            (return-wrapper ,return-type :error-generator return-posix-error/restart)
 119          ,@args))))