/[meta-cvs]/meta-cvs/F-258A1D35AE34AADD34D34F5A328405CC.lisp
ViewVC logotype

Contents of /meta-cvs/F-258A1D35AE34AADD34D34F5A328405CC.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Mon Jul 26 05:35:49 2004 UTC (9 years, 8 months ago) by kaz
Branch: MAIN
Changes since 1.11: +10 -8 lines
Merging from mcvs-1-0-branch.

* code/unix-bindings/unix.lisp: Get rid of bogus version check
which assumes that the version can be read as a floating point
number! Rather than rely on the version, check for the specific
features.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (push :clisp-unix-funcs *features*)
6
7 (defpackage :unix-funcs
8 (:use :common-lisp)
9 (:shadowing-import-from :ffi
10 :def-call-out :def-c-struct :c-array-max :c-pointer :c-ptr :c-string :int
11 :uint :ulong :boolean :character :c-array-ptr)
12 (:shadow
13 :open :close)
14 (:intern
15 :def-c-call-out)
16 (:export
17 :null-pointer-p :errno :strerror :eperm :enoent :esrch :eintr :eio
18 :enxio :e2big :enoexec :ebadf :echild :eagain :enomem :eacces
19 :efault :enotblk :ebusy :eexist :exdev :enodev :enotdir :eisdir
20 :einval :enfile :emfile :enotty :etxtbsy :efbig :enospc :espipe
21 :erofs :emlink :epipe :edom :erange :edeadlk :enametoolong :enolck
22 :enosys :enotempty :eloop :ewouldblock :dirent :opendir :closedir
23 :readdir :ino :name :open :close :chdir :fchdir :link :symlink
24 :readlink :unlink :rmdir :stat :stat :lstat :fstat :chmod
25 :mode :nlink :uid
26 :gid :rdev :blksize :blocks :atime :mtime :ctime :s-ifmt :s-ifdir
27 :s-ifchr :s-ifblk :s-ifreg :s-ififo :s-iflnk :s-ifsock :s-isdir
28 :s-ischr :s-isblk :s-isreg :s-isfifo :s-islnk :s-issock :s-isuid
29 :s-isgid :s-isvtx :s-iread :s-iwrite :s-iexec :s-irusr :s-iwusr
30 :s-ixusr :s-irwxu :s-irgrp :s-iwgrp :s-ixgrp :s-irwxg :s-iroth
31 :s-iwoth :s-ixoth :s-irwxo :accessperms :deffilemode :o-accmode
32 :o-rdonly :o-wronly :o-rdwr :o-creat :o-excl :o-noctty :o-trunc
33 :o-append :o-nonblock :o-sync :o-async :o-ndelay :o-fsync :getcwd
34 :run-program default-sigchld ctermid))
35
36 (in-package :unix-funcs)
37
38 (defmacro def-c-call-out (sym &body args)
39 `(def-call-out ,sym (:language :stdc) ,@args))
40
41 ;;;
42 ;;; In CLISP versions newer than 2.30, two new global boolean
43 ;;; variables exist in the FFI package. They must be set to
44 ;;; T to obtain an old compiler behavior.
45 ;;;
46 (eval-when (:compile-toplevel)
47 (when (find-symbol "*OUTPUT-C-FUNCTIONS*" "FFI")
48 (setf ffi:*output-c-functions* t))
49 (when (find-symbol "*OUTPUT-C-VARIABLES*" "FFI")
50 (setf ffi:*output-c-variables* t)))
51
52 ;;;
53 ;;; Null pointer test, needed in CLISP 2.27 and older.
54 ;;;
55
56 (def-c-call-out null-pointer-p
57 (:name "mcvs_null_pointer_p")
58 (:arguments (pointer c-pointer))
59 (:return-type boolean))
60
61 ;;;
62 ;;; <errno.h>
63 ;;;
64
65 (def-c-call-out get-errno
66 (:name "mcvs_get_errno")
67 (:arguments)
68 (:return-type int))
69
70 (def-c-call-out set-errno
71 (:name "mcvs_set_errno")
72 (:arguments (value int))
73 (:return-type int))
74
75 (defsetf get-errno set-errno)
76 (define-symbol-macro errno (get-errno))
77
78 (def-c-call-out strerror
79 (:arguments (errnum int))
80 (:return-type c-string :none))
81
82 (defconstant eperm 1)
83 (defconstant enoent 2)
84 (defconstant esrch 3)
85 (defconstant eintr 4)
86 (defconstant eio 5)
87 (defconstant enxio 6)
88 (defconstant e2big 7)
89 (defconstant enoexec 8)
90 (defconstant ebadf 9)
91 (defconstant echild 10)
92 (defconstant eagain 11)
93 (defconstant enomem 12)
94 (defconstant eacces 13)
95 (defconstant efault 14)
96 (defconstant enotblk 15)
97 (defconstant ebusy 16)
98 (defconstant eexist 17)
99 (defconstant exdev 18)
100 (defconstant enodev 19)
101 (defconstant enotdir 20)
102 (defconstant eisdir 21)
103 (defconstant einval 22)
104 (defconstant enfile 23)
105 (defconstant emfile 24)
106 (defconstant enotty 25)
107 (defconstant etxtbsy 26)
108 (defconstant efbig 27)
109 (defconstant enospc 28)
110 (defconstant espipe 29)
111 (defconstant erofs 30)
112 (defconstant emlink 31)
113 (defconstant epipe 32)
114 (defconstant edom 33)
115 (defconstant erange 34)
116 (defconstant edeadlk 35)
117 (defconstant enametoolong 36)
118 (defconstant enolck 37)
119 (defconstant enosys 38)
120 (defconstant enotempty 39)
121 (defconstant eloop 40)
122 (defconstant ewouldblock eagain)
123
124 ;;;
125 ;;; <dirent.h>
126 ;;;
127
128 (def-c-struct dirent
129 (ino ulong)
130 (name (c-array-max character 1024)))
131
132 (def-c-call-out opendir
133 (:arguments (name c-string))
134 (:return-type c-pointer))
135
136 (def-c-call-out closedir
137 (:arguments (dirp c-pointer))
138 (:return-type int))
139
140 (def-c-call-out readdir
141 (:name "mcvs_readdir")
142 (:arguments (dirp c-pointer))
143 (:return-type (c-ptr dirent)))
144
145 ;;;
146 ;;; <unistd.h> -- open, close
147 ;;;
148
149 (def-c-call-out open
150 (:arguments (name c-string)
151 (flags int)
152 (mode uint))
153 (:return-type int))
154
155 (def-c-call-out close
156 (:arguments (fd int))
157 (:return-type int))
158
159 ;;;
160 ;;; <unistd.h> -- chdir, fchdir
161 ;;;
162
163 (def-c-call-out chdir
164 (:arguments (path c-string))
165 (:return-type int))
166
167 (def-c-call-out fchdir
168 (:arguments (fd int))
169 (:return-type int))
170
171 ;;;
172 ;;; <unistd.h> -- link, symlink, readlink, unlink, rmdir
173
174
175 (def-c-call-out link
176 (:arguments (from c-string)
177 (to c-string))
178 (:return-type int))
179
180 (def-c-call-out symlink
181 (:arguments (from c-string)
182 (to c-string))
183 (:return-type int))
184
185 (def-c-call-out readlink
186 (:name "mcvs_readlink")
187 (:arguments (path c-string))
188 (:return-type c-string :malloc-free))
189
190 (def-c-call-out unlink
191 (:arguments (path c-string))
192 (:return-type int))
193
194 (def-c-call-out rmdir
195 (:arguments (path c-string))
196 (:return-type int))
197
198 ;;;
199 ;;; <unistd.h> -- stat, lstat, chmod
200 ;;;
201
202 (def-c-struct stat
203 (dev ulong)
204 (ino ulong)
205 (mode ulong)
206 (nlink uint)
207 (uid uint)
208 (gid uint)
209 (rdev ulong)
210 (blksize ulong)
211 (blocks ulong)
212 (atime ulong)
213 (mtime ulong)
214 (ctime ulong))
215
216 (def-c-call-out stat
217 (:name "mcvs_stat")
218 (:arguments (name c-string)
219 (buf (c-ptr stat) :out))
220 (:return-type int))
221
222 (def-c-call-out lstat
223 (:name "mcvs_lstat")
224 (:arguments (name c-string)
225 (buf (c-ptr stat) :out))
226 (:return-type int))
227
228 (def-c-call-out fstat
229 (:name "mcvs_fstat")
230 (:arguments (fd int)
231 (buf (c-ptr stat) :out))
232 (:return-type int))
233
234 (def-c-call-out chmod
235 (:arguments (name c-string)
236 (mode uint))
237 (:return-type int))
238
239 (defconstant s-ifmt #o170000)
240 (defconstant s-ifdir #o040000)
241 (defconstant s-ifchr #o020000)
242 (defconstant s-ifblk #o060000)
243 (defconstant s-ifreg #o100000)
244 (defconstant s-ififo #o010000)
245 (defconstant s-iflnk #o120000)
246 (defconstant s-ifsock #o140000)
247
248 (defmacro s-isdir (m) `(= (logand ,m s-ifmt) s-ifdir))
249 (defmacro s-ischr (m) `(= (logand ,m s-ifmt) s-ifchr))
250 (defmacro s-isblk (m) `(= (logand ,m s-ifmt) s-ifblk))
251 (defmacro s-isreg (m) `(= (logand ,m s-ifmt) s-ifreg))
252 (defmacro s-isfifo (m) `(= (logand ,m s-ifmt) s-iffifo))
253 (defmacro s-islnk (m) `(= (logand ,m s-ifmt) s-iflnk))
254 (defmacro s-issock (m) `(= (logand ,m s-ifmt) s-ifsock))
255
256 (defconstant s-isuid #o004000)
257 (defconstant s-isgid #o002000)
258 (defconstant s-isvtx #o001000)
259
260 (define-symbol-macro s-iread s-irusr)
261 (define-symbol-macro s-iwrite s-iwusr)
262 (define-symbol-macro s-iexec s-ixusr)
263
264 (defconstant s-irusr #o000400)
265 (defconstant s-iwusr #o000200)
266 (defconstant s-ixusr #o000100)
267 (defconstant s-irwxu (logior s-irusr s-iwusr s-ixusr))
268 (defconstant s-irgrp #o000040)
269 (defconstant s-iwgrp #o000020)
270 (defconstant s-ixgrp #o000010)
271 (defconstant s-irwxg (logior s-irgrp s-iwgrp s-ixgrp))
272 (defconstant s-iroth #o000004)
273 (defconstant s-iwoth #o000002)
274 (defconstant s-ixoth #o000001)
275 (defconstant s-irwxo (logior s-iroth s-iwoth s-ixoth))
276
277 (defconstant accessperms (logior s-irwxu s-irwxg s-irwxo))
278 (defconstant deffilemode (logior s-irusr s-iwusr s-irgrp s-iwgrp s-iroth s-iwoth))
279
280 ;;;
281 ;;; <unistd.h> -- getcwd
282 ;;;
283
284 (def-c-call-out getcwd
285 (:name "mcvs_getcwd")
286 (:arguments)
287 (:return-type c-string :malloc-free))
288
289 ;;;
290 ;;; <unistd.h> -- fork, wait*, exec*
291 ;;;
292
293 (def-c-call-out default-sigchld
294 (:name "mcvs_default_sigchld"))
295
296 (def-c-call-out spawn
297 (:name "mcvs_spawn")
298 (:arguments (name c-string)
299 (argv (c-array-ptr c-string) :in :malloc-free))
300 (:return-type int))
301
302 (defun run-program (name &key arguments)
303 (push name arguments)
304 (spawn name (coerce arguments 'vector)))
305
306 ;;;
307 ;;; Terminal related functions
308 ;;;
309
310 (def-c-call-out ctermid
311 (:name "mcvs_ctermid")
312 (:arguments)
313 (:return-type c-string :malloc-free))
314
315 ;;;
316 ;;; <fcntl.h>
317 ;;;
318
319 (defconstant o-accmode #o00003)
320 (defconstant o-rdonly #o00000)
321 (defconstant o-wronly #o00001)
322 (defconstant o-rdwr #o00002)
323 (defconstant o-creat #o00100)
324 (defconstant o-excl #o00200)
325 (defconstant o-noctty #o00400)
326 (defconstant o-trunc #o01000)
327 (defconstant o-append #o02000)
328 (defconstant o-nonblock #o04000)
329 (defconstant o-sync #o10000)
330 (defconstant o-async #o20000)
331 (defconstant o-ndelay o-nonblock)
332 (defconstant o-fsync o-sync)

  ViewVC Help
Powered by ViewVC 1.1.5