contrib/sb-posix/macros.lisp

   1 (in-package :sb-posix-internal)
   2
   3 ;;; some explanation may be necessary.  The namestring "[foo]"
   4 ;;; denotes a wild pathname.  When there's a file on the disk whose
   5 ;;; Unix name is "[foo]", the appropriate CL namestring for it is
   6 ;;; "\\[foo]".  So, don't call NAMESTRING, instead call a function
   7 ;;; that gets us the Unix name
   8
   9 (define-designator filename c-string
  10   (pathname
  11    (sb-impl::unix-namestring (translate-logical-pathname filename) nil))
  12   (string filename))
  13
  14 (define-designator file-descriptor (integer 32)
  15   (sb-impl::file-stream (sb-impl::fd-stream-fd file-descriptor))
  16   (fixnum file-descriptor))
  17
  18 (define-designator sap-or-nil sb-sys:system-area-pointer
  19   (null (sb-sys:int-sap 0))
  20   (sb-sys:system-area-pointer sap-or-nil))
  21
  22 (defun lisp-for-c-symbol (s)
  23   (intern (substitute #\- #\_ (string-upcase s)) :sb-posix))
  24
  25 (defmacro define-call (name return-type error-predicate &rest arguments)
  26   (let ((lisp-name (lisp-for-c-symbol name)))
  27     `(progn
  28       (export ',lisp-name :sb-posix)
  29       (declaim (inline ,lisp-name))
  30       (defun ,lisp-name ,(mapcar #'car arguments)
  31         (let ((r (alien-funcall
  32                   (extern-alien
  33                    ,name
  34                    (function ,return-type
  35                              ,@(mapcar
  36                                 (lambda (x)
  37                                   (gethash (cadr x) *designator-types* (cadr x)))
  38                                 arguments)))
  39                   ,@(mapcar (lambda (x)
  40                               (if (nth-value 1 (gethash (cadr x) *designator-types*))
  41                                   `(,(intern (symbol-name (cadr x)) :sb-posix)
  42                                     ,(car x))
  43                                   (car x)))
  44                             arguments))))
  45           (if (,error-predicate r) (syscall-error) r))))))