/[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.20 - (show annotations)
Tue Mar 11 06:24:28 2008 UTC (6 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.19: +6 -7 lines
Clean-up stat-related FFI.

* code/clisp-ffi.lisp (stat): In 32 bit version, rename fields
for consistency with glibc. The paddings should be written
as 32, not 16 (though thanks to alignment, it doesn't matter).
In the IA-64 version of stat, blksize should be 64, and the
inode field near the front is the one and only inode field;
there isn't one at the tail. In the Cygwin and IA-64 structs,
the tail padding array is now expressed with c-array rather than
c-array-max.
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 (eval-when (:compile-toplevel :load-toplevel :execute)
6 (pushnew :clisp-unix-funcs *features*)
7 #-cygwin (pushnew :linux *features*))
8
9 (defpackage :unix-funcs
10 (:use :common-lisp)
11 (:shadowing-import-from :ffi
12 :def-call-out :def-c-struct :c-array-max :c-pointer :c-ptr :c-string :int
13 :uint :ulong :ushort :long :boolean :character :c-array-ptr
14 :foreign-value :c-function :c-array :uint8 :uint16 :uint32 :uint64)
15 (:shadow
16 :open :close :signal)
17 (:intern
18 :def-c-call-out)
19 (:export
20 :errno :strerror :eperm :enoent :esrch :eintr :eio
21 :enxio :e2big :enoexec :ebadf :echild :eagain :enomem :eacces
22 :efault :enotblk :ebusy :eexist :exdev :enodev :enotdir :eisdir
23 :einval :enfile :emfile :enotty :etxtbsy :efbig :enospc :espipe
24 :erofs :emlink :epipe :edom :erange :edeadlk :enametoolong :enolck
25 :enosys :enotempty :eloop :ewouldblock :dirent :opendir :closedir
26 :readdir :ino :name :open :close :chdir :fchdir :link :symlink
27 :readlink :unlink :rmdir :stat :stat :lstat :fstat :chmod
28 :mode :nlink :uid :pipe :fork :_exit :waitpid
29 :gid :rdev :blksize :blocks :atime :mtime :ctime :s-ifmt :s-ifdir
30 :s-ifchr :s-ifblk :s-ifreg :s-ififo :s-iflnk :s-ifsock :s-isdir
31 :s-ischr :s-isblk :s-isreg :s-isfifo :s-islnk :s-issock :s-isuid
32 :s-isgid :s-isvtx :s-iread :s-iwrite :s-iexec :s-irusr :s-iwusr
33 :s-ixusr :s-irwxu :s-irgrp :s-iwgrp :s-ixgrp :s-irwxg :s-iroth
34 :s-iwoth :s-ixoth :s-irwxo :accessperms :deffilemode :o-accmode
35 :o-rdonly :o-wronly :o-rdwr :o-creat :o-excl :o-noctty :o-trunc
36 :o-append :o-nonblock :o-sync :o-async :o-ndelay :o-fsync :getcwd
37 :run-program default-sigchld ctermid))
38
39 (in-package :unix-funcs)
40
41 ;;;
42 ;;; A few macros to help condense the platform switching
43 ;;;
44
45 (defmacro def-libc-call-out (name &rest args)
46 `(def-call-out ,name
47 (:language :stdc)
48 #+cygwin (:library "cygwin1.dll")
49 #+linux (:library "libc.so.6")
50 ,@args))
51
52 ;;;
53 ;;; <errno.h>
54 ;;;
55
56 (progn
57 (def-libc-call-out errno-location
58 #+linux (:name "__errno_location")
59 #+cygwin (:name "__errno")
60 (:arguments)
61 (:return-type (c-pointer int)))
62
63 (defun get-errno ()
64 (let ((loc (errno-location)))
65 (foreign-value loc)))
66
67 (defun set-errno (value)
68 (let ((loc (errno-location)))
69 (setf (foreign-value loc) value)))
70
71 (defsetf get-errno set-errno)
72
73 (define-symbol-macro errno (get-errno)))
74
75 (def-libc-call-out strerror
76 (:arguments (errnum int))
77 (:return-type c-string :none))
78
79 (defconstant eperm 1)
80 (defconstant enoent 2)
81 (defconstant esrch 3)
82 (defconstant eintr 4)
83 (defconstant eio 5)
84 (defconstant enxio 6)
85 (defconstant e2big 7)
86 (defconstant enoexec 8)
87 (defconstant ebadf 9)
88 (defconstant echild 10)
89 (defconstant eagain 11)
90 (defconstant enomem 12)
91 (defconstant eacces 13)
92 (defconstant efault 14)
93 (defconstant enotblk 15)
94 (defconstant ebusy 16)
95 (defconstant eexist 17)
96 (defconstant exdev 18)
97 (defconstant enodev 19)
98 (defconstant enotdir 20)
99 (defconstant eisdir 21)
100 (defconstant einval 22)
101 (defconstant enfile 23)
102 (defconstant emfile 24)
103 (defconstant enotty 25)
104 (defconstant etxtbsy 26)
105 (defconstant efbig 27)
106 (defconstant enospc 28)
107 (defconstant espipe 29)
108 (defconstant erofs 30)
109 (defconstant emlink 31)
110 (defconstant epipe 32)
111 (defconstant edom 33)
112 (defconstant erange 34)
113
114 ;;;
115 ;;; <dirent.h>
116 ;;;
117
118 #+linux
119 (def-c-struct dirent
120 ;; Actually this is struct dirent64
121 (ino uint64)
122 (off uint64)
123 (reclen uint16)
124 (type uint8)
125 (name (c-array-max character 256)))
126
127 #+cygwin
128 (def-c-struct dirent
129 (version uint32)
130 (reserved (c-array uint32 2))
131 (fd uint32)
132 (ino uint32)
133 (name (c-array-max character 256)))
134
135 (def-libc-call-out opendir
136 (:arguments (name c-string))
137 (:return-type c-pointer))
138
139 (def-libc-call-out closedir
140 (:arguments (dirp c-pointer))
141 (:return-type int))
142
143 (progn
144 (def-libc-call-out readdir
145 #+linux (:name "readdir64")
146 #+cygwin (:name "readdir")
147 (:arguments (dirp c-pointer))
148 (:return-type (c-ptr dirent))))
149
150
151
152 ;;;
153 ;;; <unistd.h> -- open, close
154 ;;;
155
156 (def-libc-call-out open
157 (:arguments (name c-string)
158 (flags int)
159 (mode uint))
160 (:return-type int))
161
162 (def-libc-call-out close
163 (:arguments (fd int))
164 (:return-type int))
165
166 ;;;
167 ;;; <unistd.h> -- chdir, fchdir
168 ;;;
169
170 (def-libc-call-out chdir
171 (:arguments (path c-string))
172 (:return-type int))
173
174 (def-libc-call-out fchdir
175 (:arguments (fd int))
176 (:return-type int))
177
178 ;;;
179 ;;; <unistd.h> -- link, symlink, readlink, unlink, rmdir
180
181
182 (def-libc-call-out link
183 (:arguments (from c-string)
184 (to c-string))
185 (:return-type int))
186
187 (def-libc-call-out symlink
188 (:arguments (from c-string)
189 (to c-string))
190 (:return-type int))
191
192 (def-libc-call-out readlink-ll
193 (:name "readlink")
194 (:arguments (path c-string)
195 (buf (c-ptr (c-array-max character 4096)) :out :alloca)
196 (size ulong))
197 (:return-type int))
198
199 (defun readlink (path)
200 (multiple-value-bind (result link)
201 (readlink-ll path 4096)
202 (if (> result 0) link nil)))
203
204 (def-libc-call-out unlink
205 (:arguments (path c-string))
206 (:return-type int))
207
208 (def-libc-call-out rmdir
209 (:arguments (path c-string))
210 (:return-type int))
211
212 ;;;
213 ;;; <unistd.h> -- stat, lstat, chmod
214 ;;;
215
216 #+(and linux (not arch-x86_64))
217 (def-c-struct stat
218 ;; actually, this is stat64
219 (dev uint64)
220 (__pad1 uint32)
221 (__ino uint32)
222 (mode uint32)
223 (nlink uint32)
224 (uid uint32)
225 (gid uint32)
226 (rdev uint64)
227 (__pad2 uint32)
228 (size uint64)
229 (blksize uint32)
230 (blocks uint64)
231 (atime uint32)
232 (atime-nsec uint32)
233 (mtime uint32)
234 (mtime-nsec uint32)
235 (ctime uint32)
236 (ctime-nsec uint32)
237 (ino uint64))
238
239 #+(and linux arch-x86_64)
240 (def-c-struct stat
241 ;; actually, this is stat64
242 (dev uint64)
243 (ino uint64)
244 (nlink uint64)
245 (mode uint32)
246 (uid uint32)
247 (gid uint32)
248 (__pad0 uint32)
249 (rdev uint64)
250 (size uint64)
251 (blksize uint64)
252 (blocks uint64)
253 (atime uint64)
254 (atime-nsec uint64)
255 (mtime uint64)
256 (mtime-nsec uint64)
257 (ctime uint64)
258 (ctime-nsec uint64)
259 (__unused (c-array uint64 3)))
260
261 #+cygwin
262 (def-c-struct stat
263 (dev uint32)
264 (ino uint64)
265 (mode uint32)
266 (nlink uint16)
267 (uid uint32)
268 (gid uint32)
269 (rdev uint32)
270 (size uint64)
271 (atime uint32)
272 (atime-nsec uint32)
273 (mtime uint32)
274 (mtime-nsec uint32)
275 (ctime uint32)
276 (ctime-nsec uint32)
277 (blksize uint32)
278 (blkcnt uint64)
279 (spare4 (c-array uint32 2)))
280
281 #+linux
282 (progn
283 #+arch-x86_64 (defconstant __stat-ver-linux 1)
284 #-arch-x86_64 (defconstant __stat-ver-linux 3)
285
286 (def-libc-call-out __xstat64
287 (:arguments (version int)
288 (name c-string)
289 (buf (c-ptr stat) :out))
290 (:return-type int))
291
292 (def-libc-call-out __lxstat64
293 (:arguments (version int)
294 (name c-string)
295 (buf (c-ptr stat) :out))
296 (:return-type int))
297
298 (def-libc-call-out __fxstat64
299 (:arguments (version int)
300 (fd int)
301 (buf (c-ptr stat) :out))
302 (:return-type int))
303
304 (declaim (inline stat) (inline fstat) (inline lstat))
305
306 (defun stat (name) (__xstat64 __stat-ver-linux name))
307 (defun fstat (name) (__fxstat64 __stat-ver-linux name))
308 (defun lstat (name) (__lxstat64 __stat-ver-linux name)))
309
310 #+cygwin
311 (progn
312 (def-libc-call-out stat
313 (:name "_stat64")
314 (:arguments (name c-string)
315 (buf (c-ptr stat) :out))
316 (:return-type int))
317
318 (def-libc-call-out lstat
319 (:name "_lstat64")
320 (:arguments (name c-string)
321 (buf (c-ptr stat) :out))
322 (:return-type int))
323
324 (def-libc-call-out fstat
325 (:name "_fstat64")
326 (:arguments (fd int)
327 (buf (c-ptr stat) :out))
328 (:return-type int)))
329
330 (def-libc-call-out chmod
331 (:arguments (name c-string)
332 (mode uint))
333 (:return-type int))
334
335 (defconstant s-ifmt #o170000)
336 (defconstant s-ifdir #o040000)
337 (defconstant s-ifchr #o020000)
338 (defconstant s-ifblk #o060000)
339 (defconstant s-ifreg #o100000)
340 (defconstant s-ififo #o010000)
341 (defconstant s-iflnk #o120000)
342 (defconstant s-ifsock #o140000)
343
344 (defmacro s-isdir (m) `(= (logand ,m s-ifmt) s-ifdir))
345 (defmacro s-ischr (m) `(= (logand ,m s-ifmt) s-ifchr))
346 (defmacro s-isblk (m) `(= (logand ,m s-ifmt) s-ifblk))
347 (defmacro s-isreg (m) `(= (logand ,m s-ifmt) s-ifreg))
348 (defmacro s-isfifo (m) `(= (logand ,m s-ifmt) s-iffifo))
349 (defmacro s-islnk (m) `(= (logand ,m s-ifmt) s-iflnk))
350 (defmacro s-issock (m) `(= (logand ,m s-ifmt) s-ifsock))
351
352 (defconstant s-isuid #o004000)
353 (defconstant s-isgid #o002000)
354 (defconstant s-isvtx #o001000)
355
356 (define-symbol-macro s-iread s-irusr)
357 (define-symbol-macro s-iwrite s-iwusr)
358 (define-symbol-macro s-iexec s-ixusr)
359
360 (defconstant s-irusr #o000400)
361 (defconstant s-iwusr #o000200)
362 (defconstant s-ixusr #o000100)
363 (defconstant s-irwxu (logior s-irusr s-iwusr s-ixusr))
364 (defconstant s-irgrp #o000040)
365 (defconstant s-iwgrp #o000020)
366 (defconstant s-ixgrp #o000010)
367 (defconstant s-irwxg (logior s-irgrp s-iwgrp s-ixgrp))
368 (defconstant s-iroth #o000004)
369 (defconstant s-iwoth #o000002)
370 (defconstant s-ixoth #o000001)
371 (defconstant s-irwxo (logior s-iroth s-iwoth s-ixoth))
372
373 (defconstant accessperms (logior s-irwxu s-irwxg s-irwxo))
374 (defconstant deffilemode (logior s-irusr s-iwusr s-irgrp s-iwgrp s-iroth s-iwoth))
375
376 ;;;
377 ;;; <unistd.h> -- pipe
378 ;;;
379
380 (def-libc-call-out pipe
381 (:arguments (filedes (c-ptr (c-array-max int 2)) :out))
382 (:return-type int))
383
384 ;;;
385 ;;; <signal.h>
386 ;;;
387
388
389 #+(or linux cygwin)
390 (progn
391 (defconstant sig-err -1)
392 (defconstant sig-dfl 0)
393 (defconstant sig-ign 1))
394
395 #+linux
396 (progn
397 (defconstant sighup 1)
398 (defconstant sigint 2)
399 (defconstant sigquit 3)
400 (defconstant sigill 4)
401 (defconstant sigtrap 5)
402 (defconstant sigabrt 6)
403 (defconstant sigiot 6)
404 (defconstant sigbus 7)
405 (defconstant sigfpe 8)
406 (defconstant sigkill 9)
407 (defconstant sigusr1 10)
408 (defconstant sigsegv 11)
409 (defconstant sigusr2 12)
410 (defconstant sigpipe 13)
411 (defconstant sigalrm 14)
412 (defconstant sigterm 15)
413 (defconstant sigstkflt 16)
414 (defconstant sigchld 17)
415 (defconstant sigcld sigchld)
416 (defconstant sigcont 18)
417 (defconstant sigstop 19)
418 (defconstant sigtstp 20)
419 (defconstant sigttin 21)
420 (defconstant sigttou 22)
421 (defconstant sigurg 23)
422 (defconstant sigxcpu 24)
423 (defconstant sigxfsz 25)
424 (defconstant sigvtalrm 26)
425 (defconstant sigprof 27)
426 (defconstant sigwinch 28)
427 (defconstant sigio 29)
428 (defconstant sigpoll sigio)
429 (defconstant sigpwr 30)
430 (defconstant sigsys 31)
431 (defconstant sigunused 31))
432
433 #+cygwin
434 (progn
435 (defconstant sighup 1)
436 (defconstant sigint 2)
437 (defconstant sigquit 3)
438 (defconstant sigill 4)
439 (defconstant sigtrap 5)
440 (defconstant sigabrt 6)
441 (defconstant sigemt 7)
442 (defconstant sigfpe 8)
443 (defconstant sigkill 9)
444 (defconstant sigbus 10)
445 (defconstant sigsegv 11)
446 (defconstant sigsys 12)
447 (defconstant sigpipe 13)
448 (defconstant sigalrm 14)
449 (defconstant sigterm 15)
450 (defconstant sigurg 16)
451 (defconstant sigstop 17)
452 (defconstant sigtstp 18)
453 (defconstant sigcont 19)
454 (defconstant sigchld 20)
455 (defconstant sigcld 20)
456 (defconstant sigttin 21)
457 (defconstant sigttou 22)
458 (defconstant sigio 23)
459 (defconstant sigpoll sigio)
460 (defconstant sigxcpu 24)
461 (defconstant sigxfsz 25)
462 (defconstant sigvtalrm 26)
463 (defconstant sigprof 27)
464 (defconstant sigwinch 28)
465 (defconstant siglost 29)
466 (defconstant sigusr1 30)
467 (defconstant sigusr2 31))
468
469 (def-libc-call-out signal-ll
470 (:name "signal")
471 (:arguments (num int)
472 (handler (c-function (:language :stdc)
473 (:arguments (num int))
474 (:return-type))))
475 (:return-type ulong))
476
477 (def-libc-call-out signal-hack-ll
478 (:name "signal")
479 (:arguments (num int) (handler ulong))
480 (:return-type ulong))
481
482 (declaim (inline signal))
483 (defun signal (num func)
484 (if (functionp func)
485 (signal-ll num func)
486 (signal-hack-ll num func)))
487
488 ;;;
489 ;;; <unistd.h> -- getcwd
490 ;;;
491
492 (progn
493 (def-libc-call-out getcwd-ll
494 (:name "getcwd")
495 ;; this is char on purpose, since we take the returned value,
496 ;; and ignore the :out parameter. It would be a waste of cycles
497 ;; to put it through a charset encoder.
498 (:arguments (buf (c-ptr (c-array-max char 4096)) :out :alloca)
499 (size ulong))
500 (:return-type c-string))
501
502 (defun getcwd ()
503 (values (getcwd-ll 4096))))
504
505 ;;;
506 ;;; <unistd.h> -- fork, wait*, exec*
507 ;;;
508
509 (defun default-sigchld ()
510 (signal sigchld sig-dfl))
511
512 (def-libc-call-out fork
513 (:arguments)
514 (:return-type int))
515
516 (def-libc-call-out waitpid
517 (:arguments (pid int) (status (c-ptr int) :out) (options int))
518 (:return-type int))
519
520 (def-libc-call-out execvp
521 (:arguments (file c-string) (argv (c-array-ptr c-string)))
522 (:return-type int))
523
524 (def-libc-call-out _exit
525 (:arguments (status int))
526 (:return-type))
527
528 (defmacro wexitstatus (status) `(ash (logand ,status #xff00) -8))
529
530 ;;; if wifsignaled is true, gives the terminating signal
531 (defmacro wtermsig (status) `(logand ,status #x7f))
532
533 ;;; if wifstopped is true, gives signal that stopped child
534 (defmacro wstopsig (status) `(wexitstatus ,status))
535
536 (defmacro wifexited (status) `(zerop (wtermsig ,status)))
537
538 (defmacro wifsignaled (status) `(< 0 (logand ,status #x7f) 0x7f))
539
540 (defmacro wifsignaled (status) `(= (logand ,status #x7f) 0x7f))
541
542 (defconstant wnohang 1)
543 (defconstant wuntraced 2)
544 (defconstant wcontinued 3)
545
546 (defun spawn (name argument-vector)
547 (default-sigchld)
548 (let ((child (fork)))
549 (cond
550 ((< child 0) nil)
551 ((zerop child)
552 (execvp name argument-vector)
553 (_exit 1))
554 (t (loop
555 (multiple-value-bind (result status)
556 (waitpid child 0)
557 (if (or (>= result 0) (/= eintr errno))
558 (when (wifexited status)
559 (return (wexitstatus status)))
560 (return result))))))))
561
562 (defun run-program (name &key arguments)
563 (push name arguments)
564 (spawn name (coerce arguments 'vector)))
565
566 ;;;
567 ;;; Terminal related functions
568 ;;;
569
570 (defconstant l-ctermid 9)
571
572 (def-libc-call-out ctermid-ll
573 (:name "ctermid")
574 (:arguments (buf (c-ptr (c-array-max char 10)) :out))
575 (:return-type c-string))
576
577 (defun ctermid ()
578 (values (ctermid-ll)))
579
580 ;;;
581 ;;; <fcntl.h>
582 ;;;
583
584 (defconstant o-accmode #o00003)
585 (defconstant o-rdonly #o00000)
586 (defconstant o-wronly #o00001)
587 (defconstant o-rdwr #o00002)
588 (defconstant o-creat #o00100)
589 (defconstant o-excl #o00200)
590 (defconstant o-noctty #o00400)
591 (defconstant o-trunc #o01000)
592 (defconstant o-append #o02000)
593 (defconstant o-nonblock #o04000)
594 (defconstant o-sync #o10000)
595 (defconstant o-async #o20000)
596 (defconstant o-ndelay o-nonblock)
597 (defconstant o-fsync o-sync)

  ViewVC Help
Powered by ViewVC 1.1.5