contrib/sb-posix/macros.lisp

   1 (in-package :sb-posix)
   2
   3 (define-designator filename (string c-string)
   4   ("A STRING designating a filename in native namestring syntax.
   5
   6 Note that native namestring syntax is distinct from Lisp namestring syntax:
   7
   8   \(pathname \"/foo*/bar\")
   9
  10 is a wild pathname with a pattern-matching directory component.
  11 SB-EXT:PARSE-NATIVE-NAMESTRING may be used to construct Lisp pathnames that
  12 denote POSIX filenames as understood by system calls, and
  13 SB-EXT:NATIVE-NAMESTRING can be used to coerce them into strings in the native
  14 namestring syntax.
  15
  16 Note also that POSIX filename syntax does not distinguish the names of files
  17 from the names of directories: in order to parse the name of a directory in
  18 POSIX filename syntax into a pathname MY-DEFAULTS for which
  19
  20   \(merge-pathnames (make-pathname :name \"FOO\" :case :common)
  21                     my-defaults)
  22
  23 returns a pathname that denotes a file in the directory, supply a true
  24 :AS-DIRECTORY argument to SB-EXT:PARSE-NATIVE-NAMESTRING. Likewise, to supply
  25 the name of a directory to a POSIX function in non-directory syntax, supply a
  26 true :AS-FILE argument to SB-EXT:NATIVE-NAMESTRING."
  27    "Designator for a FILENAME: a STRING designating itself, or a
  28 designator for a PATHNAME designating the corresponding native namestring."
  29    "Converts FILENAME-DESIGNATOR into a FILENAME.")
  30   (pathname
  31    (sb-ext:native-namestring (translate-logical-pathname filename)
  32                              :as-file t))
  33   (string
  34    filename)
  35   (stream
  36    (filename (pathname filename))))
  37
  38 (define-designator file-descriptor (fixnum (integer 32))
  39     ("A FIXNUM designating a native file descriptor.
  40
  41 SB-SYS:MAKE-FD-STREAM can be used to construct a FILE-STREAM associated with a
  42 native file descriptor.
  43
  44 Note that mixing I/O operations on a FILE-STREAM with operations directly on its
  45 descriptor may produce unexpected results if the stream is buffered."
  46      "Designator for a FILE-DESCRIPTOR: either a fixnum designating itself, or
  47 a FILE-STREAM designating the underlying file-descriptor."
  48      "Converts FILE-DESCRIPTOR-DESIGNATOR into a FILE-DESCRIPTOR.")
  49   (file-stream
  50    (sb-sys:fd-stream-fd file-descriptor))
  51   (fixnum
  52    file-descriptor))
  53
  54 (define-designator sap-or-nil (sb-sys:system-area-pointer sb-sys:system-area-pointer)
  55     ()
  56   (null (sb-sys:int-sap 0))
  57   (sb-sys:system-area-pointer sap-or-nil))
  58
  59 (define-designator alien-pointer-to-anything-or-nil (sb-alien-internals::alien-value (* t))
  60     ()
  61   (null (sb-alien:sap-alien (sb-sys:int-sap 0) (* t)))
  62   ((alien (* t)) alien-pointer-to-anything-or-nil))
  63
  64 (defun lisp-for-c-symbol (name)
  65   (etypecase name
  66     (list
  67      (lisp-for-c-symbol (car name)))
  68     (string
  69      (let ((root (if (eql #\_ (char name 0)) (subseq name 1) name)))
  70        (intern (substitute #\- #\_ (string-upcase root)) :sb-posix)))))
  71
  72 ;; Note: this variable is set in interface.lisp.  defined here for
  73 ;; clarity and so the real-c-name compile as desired.
  74 (defparameter *c-functions-in-runtime* nil)
  75
  76 (defun real-c-name (name)
  77   (let  ((maybe-name
  78           (etypecase name
  79             (list
  80              (destructuring-bind (name &key c-name options) name
  81                (declare (ignorable options))
  82                (if c-name
  83                    c-name
  84                    (cond #+largefile
  85                          ((or (eql options :largefile)
  86                               (member :largefile options))
  87                           (format nil "~a_largefile" name))
  88                          (t
  89                           name)))))
  90             (string
  91              name))))
  92     (if (member maybe-name *c-functions-in-runtime*
  93                 :test #'string=)
  94         (format nil "_~A" maybe-name)
  95         maybe-name)))
  96
  97 (defmacro define-call-internally (lisp-name c-name return-type error-predicate
  98                                   &rest arguments)
  99   (if (sb-sys:find-foreign-symbol-address c-name)
 100       `(progn
 101         (declaim (inline ,lisp-name))
 102         (defun ,lisp-name ,(mapcar #'car arguments)
 103           (let ((r (alien-funcall
 104                     (extern-alien
 105                      ,c-name
 106                      (function ,return-type
 107                                ,@(mapcar
 108                                   (lambda (x)
 109                                     (gethash (cadr x)
 110                                              *designator-types*
 111                                              (cadr x)))
 112                                   arguments)))
 113                     ,@(mapcar (lambda (x)
 114                                 (if (nth-value 1
 115                                                (gethash (cadr x)
 116                                                         *designator-types*))
 117                                     `(,(intern (symbol-name (cadr x))
 118                                                :sb-posix)
 119                                       ,(car x))
 120                                     (car x)))
 121                               arguments))))
 122             (if (,error-predicate r) (syscall-error ',lisp-name) r))))
 123       `(sb-int:style-warn "Didn't find definition for ~S" ,c-name)))
 124
 125 (defmacro define-call (name return-type error-predicate &rest arguments)
 126   (let ((lisp-name (lisp-for-c-symbol name))
 127         (real-c-name (real-c-name name)))
 128     `(progn
 129        (export ',lisp-name :sb-posix)
 130        (define-call-internally ,lisp-name
 131            ,real-c-name
 132          ,return-type
 133          ,error-predicate
 134          ,@arguments))))
 135
 136 (defmacro define-entry-point (name arglist &body body)
 137   (let ((lisp-name (lisp-for-c-symbol name)))
 138     `(progn
 139       (export ',lisp-name :sb-posix)
 140       (declaim (inline ,lisp-name))
 141       (defun ,lisp-name ,arglist
 142         ,@body))))
 143
 144 (defmacro define-simple-call (name return-type &rest arguments)
 145   (multiple-value-bind (lisp-name c-name)
 146       (values name (substitute #\_ #\- (string-downcase name)))
 147     `(progn
 148        (export ',lisp-name :sb-posix)
 149        (defun ,lisp-name ,(mapcar #'first arguments)
 150          (alien-funcall (extern-alien ,c-name (function ,return-type
 151                                                         ,@(mapcar #'second arguments)))
 152                         ,@(mapcar #'first arguments))))))