/[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 - (hide 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 kaz 1.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 kaz 1.14 (eval-when (:compile-toplevel :load-toplevel :execute)
6     (pushnew :clisp-unix-funcs *features*)
7 kaz 1.17 #-cygwin (pushnew :linux *features*))
8 kaz 1.6
9 kaz 1.1 (defpackage :unix-funcs
10 kaz 1.6 (: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 kaz 1.15 :uint :ulong :ushort :long :boolean :character :c-array-ptr
14 kaz 1.14 :foreign-value :c-function :c-array :uint8 :uint16 :uint32 :uint64)
15 kaz 1.6 (:shadow
16 kaz 1.14 :open :close :signal)
17 kaz 1.6 (:intern
18     :def-c-call-out)
19     (:export
20 kaz 1.13 :errno :strerror :eperm :enoent :esrch :eintr :eio
21 kaz 1.6 :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 kaz 1.16 :mode :nlink :uid :pipe :fork :_exit :waitpid
29 kaz 1.6 :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 kaz 1.7 :o-append :o-nonblock :o-sync :o-async :o-ndelay :o-fsync :getcwd
37 kaz 1.10 :run-program default-sigchld ctermid))
38 kaz 1.1
39     (in-package :unix-funcs)
40 kaz 1.14
41     ;;;
42     ;;; A few macros to help condense the platform switching
43     ;;;
44 kaz 1.1
45 kaz 1.14 (defmacro def-libc-call-out (name &rest args)
46 kaz 1.17 `(def-call-out ,name
47     (:language :stdc)
48     #+cygwin (:library "cygwin1.dll")
49     #+linux (:library "libc.so.6")
50     ,@args))
51 kaz 1.2
52 kaz 1.12 ;;;
53 kaz 1.1 ;;; <errno.h>
54     ;;;
55    
56 kaz 1.14 (progn
57     (def-libc-call-out errno-location
58 kaz 1.17 #+linux (:name "__errno_location")
59     #+cygwin (:name "__errno")
60 kaz 1.14 (: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 kaz 1.1
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 kaz 1.17 #+linux
119 kaz 1.1 (def-c-struct dirent
120 kaz 1.14 ;; 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 kaz 1.1
127 kaz 1.17 #+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 kaz 1.14 (def-libc-call-out opendir
136 kaz 1.1 (:arguments (name c-string))
137     (:return-type c-pointer))
138    
139 kaz 1.14 (def-libc-call-out closedir
140 kaz 1.1 (:arguments (dirp c-pointer))
141     (:return-type int))
142    
143 kaz 1.14 (progn
144     (def-libc-call-out readdir
145 kaz 1.17 #+linux (:name "readdir64")
146     #+cygwin (:name "readdir")
147 kaz 1.14 (:arguments (dirp c-pointer))
148     (:return-type (c-ptr dirent))))
149    
150    
151 kaz 1.1
152     ;;;
153     ;;; <unistd.h> -- open, close
154     ;;;
155    
156 kaz 1.14 (def-libc-call-out open
157 kaz 1.1 (:arguments (name c-string)
158     (flags int)
159     (mode uint))
160     (:return-type int))
161    
162 kaz 1.14 (def-libc-call-out close
163 kaz 1.1 (:arguments (fd int))
164     (:return-type int))
165    
166     ;;;
167     ;;; <unistd.h> -- chdir, fchdir
168     ;;;
169    
170 kaz 1.14 (def-libc-call-out chdir
171 kaz 1.1 (:arguments (path c-string))
172     (:return-type int))
173    
174 kaz 1.14 (def-libc-call-out fchdir
175 kaz 1.1 (:arguments (fd int))
176     (:return-type int))
177    
178     ;;;
179 kaz 1.4 ;;; <unistd.h> -- link, symlink, readlink, unlink, rmdir
180 kaz 1.1
181    
182 kaz 1.14 (def-libc-call-out link
183 kaz 1.1 (:arguments (from c-string)
184     (to c-string))
185     (:return-type int))
186    
187 kaz 1.14 (def-libc-call-out symlink
188 kaz 1.1 (:arguments (from c-string)
189     (to c-string))
190     (:return-type int))
191 kaz 1.4
192 kaz 1.14 (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 kaz 1.18 (if (> result 0) link nil)))
203 kaz 1.1
204 kaz 1.14 (def-libc-call-out unlink
205 kaz 1.1 (:arguments (path c-string))
206     (:return-type int))
207    
208 kaz 1.14 (def-libc-call-out rmdir
209 kaz 1.1 (:arguments (path c-string))
210     (:return-type int))
211    
212     ;;;
213 kaz 1.5 ;;; <unistd.h> -- stat, lstat, chmod
214 kaz 1.1 ;;;
215    
216 kaz 1.19 #+(and linux (not arch-x86_64))
217 kaz 1.1 (def-c-struct stat
218 kaz 1.14 ;; actually, this is stat64
219     (dev uint64)
220 kaz 1.20 (__pad1 uint32)
221 kaz 1.14 (__ino uint32)
222     (mode uint32)
223     (nlink uint32)
224     (uid uint32)
225     (gid uint32)
226     (rdev uint64)
227 kaz 1.20 (__pad2 uint32)
228 kaz 1.14 (size uint64)
229 kaz 1.17 (blksize uint32)
230 kaz 1.14 (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 kaz 1.19 #+(and linux arch-x86_64)
240     (def-c-struct stat
241     ;; actually, this is stat64
242     (dev uint64)
243 kaz 1.20 (ino uint64)
244 kaz 1.19 (nlink uint64)
245     (mode uint32)
246     (uid uint32)
247     (gid uint32)
248     (__pad0 uint32)
249     (rdev uint64)
250     (size uint64)
251 kaz 1.20 (blksize uint64)
252 kaz 1.19 (blocks uint64)
253     (atime uint64)
254     (atime-nsec uint64)
255     (mtime uint64)
256     (mtime-nsec uint64)
257     (ctime uint64)
258     (ctime-nsec uint64)
259 kaz 1.20 (__unused (c-array uint64 3)))
260 kaz 1.19
261 kaz 1.17 #+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 kaz 1.20 (spare4 (c-array uint32 2)))
280 kaz 1.17
281     #+linux
282 kaz 1.14 (progn
283 kaz 1.19 #+arch-x86_64 (defconstant __stat-ver-linux 1)
284     #-arch-x86_64 (defconstant __stat-ver-linux 3)
285 kaz 1.14
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 kaz 1.19 (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 kaz 1.1
310 kaz 1.17 #+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 kaz 1.14 (def-libc-call-out chmod
331 kaz 1.5 (:arguments (name c-string)
332     (mode uint))
333     (:return-type int))
334    
335 kaz 1.1 (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 kaz 1.3
376     ;;;
377 kaz 1.16 ;;; <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 kaz 1.14 ;;; <signal.h>
386     ;;;
387    
388    
389 kaz 1.17 #+(or linux cygwin)
390 kaz 1.14 (progn
391     (defconstant sig-err -1)
392     (defconstant sig-dfl 0)
393     (defconstant sig-ign 1))
394    
395 kaz 1.17 #+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 kaz 1.14
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 kaz 1.3 ;;; <unistd.h> -- getcwd
490 kaz 1.7 ;;;
491 kaz 1.3
492 kaz 1.14 (progn
493     (def-libc-call-out getcwd-ll
494     (:name "getcwd")
495 kaz 1.18 ;; 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 kaz 1.14 (: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 kaz 1.7
505     ;;;
506     ;;; <unistd.h> -- fork, wait*, exec*
507     ;;;
508 kaz 1.9
509 kaz 1.14 (defun default-sigchld ()
510     (signal sigchld sig-dfl))
511 kaz 1.7
512 kaz 1.14 (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 kaz 1.7 (:return-type int))
523    
524 kaz 1.14 (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 kaz 1.16 (if (or (>= result 0) (/= eintr errno))
558 kaz 1.14 (when (wifexited status)
559     (return (wexitstatus status)))
560     (return result))))))))
561    
562 kaz 1.7 (defun run-program (name &key arguments)
563     (push name arguments)
564     (spawn name (coerce arguments 'vector)))
565 kaz 1.10
566     ;;;
567     ;;; Terminal related functions
568     ;;;
569    
570 kaz 1.14 (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 kaz 1.1
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