NEWS updates.
[sbcl.git] / 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))))))