/[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.17 - (show annotations)
Tue Nov 28 02:30:40 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.16: +136 -55 lines
Ported to Cygwin.

* code/clisp-ffi.lisp (eval-when): Rename :linux-libc6 feature to
just linux. Only push it onto *features* if :cygwin isn't there.
Our platform support is restricted to Linux and Cygwin for the time
being.
(def-libc-call-out): Change macro to handle both Cygwin and Linux.
The only difference is the library.
(errno-location): Cygwin variant uses __errno function rather than
__errno_location. Otherwise it works the same as Linux.
(edeadlk, enametoolong, enolck, enosys, enotempty,
eloop, ewouldblock): Remove these error constants, since we don't
use them anyway and those that exist on Cygwin have different values.
(struct dirent): Define Cygwin variant of structure.
(readdir): Cygwin variation added.
(struct stat): Define Cygwin variant of structure. Small change in
Linux variant.
(stat, lstat, fstat): Cygwin versions defined. These go to _*64
functions.
(sighup, sigint, sigquit, sigill, sigtrap, sigabrt, sigemt,
sigfpe, sigkill, sigbus, sigsegv, sigsys, sigpipe, sigalrm,
sigterm, sigurg, sigstop, sigtstp, sigcont, sigchld, sigcld,
sigttin, sigttou, sigio, sigpoll, sigxcpu, sigxfsz, sigvtalrm,
sigprof, sigwinch, siglost, sigusr1, sigusr2): Define for Cygwin.
(getcwd-ll): Not specific to Linux, read-time conditional removed.
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) (coerce link 'string) 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 #+linux
217 (def-c-struct stat
218 ;; actually, this is stat64
219 (dev uint64)
220 (__pad0 uint16)
221 (__ino uint32)
222 (mode uint32)
223 (nlink uint32)
224 (uid uint32)
225 (gid uint32)
226 (rdev uint64)
227 (__pad1 uint16)
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 #+cygwin
240 (def-c-struct stat
241 (dev uint32)
242 (ino uint64)
243 (mode uint32)
244 (nlink uint16)
245 (uid uint32)
246 (gid uint32)
247 (rdev uint32)
248 (size uint64)
249 (atime uint32)
250 (atime-nsec uint32)
251 (mtime uint32)
252 (mtime-nsec uint32)
253 (ctime uint32)
254 (ctime-nsec uint32)
255 (blksize uint32)
256 (blkcnt uint64)
257 (spare4 (c-array-max uint32 2)))
258
259 #+linux
260 (progn
261 (defconstant stat-ver 3)
262
263 (def-libc-call-out __xstat64
264 (:arguments (version int)
265 (name c-string)
266 (buf (c-ptr stat) :out))
267 (:return-type int))
268
269 (def-libc-call-out __lxstat64
270 (:arguments (version int)
271 (name c-string)
272 (buf (c-ptr stat) :out))
273 (:return-type int))
274
275 (def-libc-call-out __fxstat64
276 (:arguments (version int)
277 (fd int)
278 (buf (c-ptr stat) :out))
279 (:return-type int))
280
281 (declaim (inline stat) (inline fstat) (inline lstat))
282
283 (defun stat (name) (__xstat64 stat-ver name))
284 (defun fstat (name) (__fxstat64 stat-ver name))
285 (defun lstat (name) (__lxstat64 stat-ver name)))
286
287 #+cygwin
288 (progn
289 (def-libc-call-out stat
290 (:name "_stat64")
291 (:arguments (name c-string)
292 (buf (c-ptr stat) :out))
293 (:return-type int))
294
295 (def-libc-call-out lstat
296 (:name "_lstat64")
297 (:arguments (name c-string)
298 (buf (c-ptr stat) :out))
299 (:return-type int))
300
301 (def-libc-call-out fstat
302 (:name "_fstat64")
303 (:arguments (fd int)
304 (buf (c-ptr stat) :out))
305 (:return-type int)))
306
307 (def-libc-call-out chmod
308 (:arguments (name c-string)
309 (mode uint))
310 (:return-type int))
311
312 (defconstant s-ifmt #o170000)
313 (defconstant s-ifdir #o040000)
314 (defconstant s-ifchr #o020000)
315 (defconstant s-ifblk #o060000)
316 (defconstant s-ifreg #o100000)
317 (defconstant s-ififo #o010000)
318 (defconstant s-iflnk #o120000)
319 (defconstant s-ifsock #o140000)
320
321 (defmacro s-isdir (m) `(= (logand ,m s-ifmt) s-ifdir))
322 (defmacro s-ischr (m) `(= (logand ,m s-ifmt) s-ifchr))
323 (defmacro s-isblk (m) `(= (logand ,m s-ifmt) s-ifblk))
324 (defmacro s-isreg (m) `(= (logand ,m s-ifmt) s-ifreg))
325 (defmacro s-isfifo (m) `(= (logand ,m s-ifmt) s-iffifo))
326 (defmacro s-islnk (m) `(= (logand ,m s-ifmt) s-iflnk))
327 (defmacro s-issock (m) `(= (logand ,m s-ifmt) s-ifsock))
328
329 (defconstant s-isuid #o004000)
330 (defconstant s-isgid #o002000)
331 (defconstant s-isvtx #o001000)
332
333 (define-symbol-macro s-iread s-irusr)
334 (define-symbol-macro s-iwrite s-iwusr)
335 (define-symbol-macro s-iexec s-ixusr)
336
337 (defconstant s-irusr #o000400)
338 (defconstant s-iwusr #o000200)
339 (defconstant s-ixusr #o000100)
340 (defconstant s-irwxu (logior s-irusr s-iwusr s-ixusr))
341 (defconstant s-irgrp #o000040)
342 (defconstant s-iwgrp #o000020)
343 (defconstant s-ixgrp #o000010)
344 (defconstant s-irwxg (logior s-irgrp s-iwgrp s-ixgrp))
345 (defconstant s-iroth #o000004)
346 (defconstant s-iwoth #o000002)
347 (defconstant s-ixoth #o000001)
348 (defconstant s-irwxo (logior s-iroth s-iwoth s-ixoth))
349
350 (defconstant accessperms (logior s-irwxu s-irwxg s-irwxo))
351 (defconstant deffilemode (logior s-irusr s-iwusr s-irgrp s-iwgrp s-iroth s-iwoth))
352
353 ;;;
354 ;;; <unistd.h> -- pipe
355 ;;;
356
357 (def-libc-call-out pipe
358 (:arguments (filedes (c-ptr (c-array-max int 2)) :out))
359 (:return-type int))
360
361 ;;;
362 ;;; <signal.h>
363 ;;;
364
365
366 #+(or linux cygwin)
367 (progn
368 (defconstant sig-err -1)
369 (defconstant sig-dfl 0)
370 (defconstant sig-ign 1))
371
372 #+linux
373 (progn
374 (defconstant sighup 1)
375 (defconstant sigint 2)
376 (defconstant sigquit 3)
377 (defconstant sigill 4)
378 (defconstant sigtrap 5)
379 (defconstant sigabrt 6)
380 (defconstant sigiot 6)
381 (defconstant sigbus 7)
382 (defconstant sigfpe 8)
383 (defconstant sigkill 9)
384 (defconstant sigusr1 10)
385 (defconstant sigsegv 11)
386 (defconstant sigusr2 12)
387 (defconstant sigpipe 13)
388 (defconstant sigalrm 14)
389 (defconstant sigterm 15)
390 (defconstant sigstkflt 16)
391 (defconstant sigchld 17)
392 (defconstant sigcld sigchld)
393 (defconstant sigcont 18)
394 (defconstant sigstop 19)
395 (defconstant sigtstp 20)
396 (defconstant sigttin 21)
397 (defconstant sigttou 22)
398 (defconstant sigurg 23)
399 (defconstant sigxcpu 24)
400 (defconstant sigxfsz 25)
401 (defconstant sigvtalrm 26)
402 (defconstant sigprof 27)
403 (defconstant sigwinch 28)
404 (defconstant sigio 29)
405 (defconstant sigpoll sigio)
406 (defconstant sigpwr 30)
407 (defconstant sigsys 31)
408 (defconstant sigunused 31))
409
410 #+cygwin
411 (progn
412 (defconstant sighup 1)
413 (defconstant sigint 2)
414 (defconstant sigquit 3)
415 (defconstant sigill 4)
416 (defconstant sigtrap 5)
417 (defconstant sigabrt 6)
418 (defconstant sigemt 7)
419 (defconstant sigfpe 8)
420 (defconstant sigkill 9)
421 (defconstant sigbus 10)
422 (defconstant sigsegv 11)
423 (defconstant sigsys 12)
424 (defconstant sigpipe 13)
425 (defconstant sigalrm 14)
426 (defconstant sigterm 15)
427 (defconstant sigurg 16)
428 (defconstant sigstop 17)
429 (defconstant sigtstp 18)
430 (defconstant sigcont 19)
431 (defconstant sigchld 20)
432 (defconstant sigcld 20)
433 (defconstant sigttin 21)
434 (defconstant sigttou 22)
435 (defconstant sigio 23)
436 (defconstant sigpoll sigio)
437 (defconstant sigxcpu 24)
438 (defconstant sigxfsz 25)
439 (defconstant sigvtalrm 26)
440 (defconstant sigprof 27)
441 (defconstant sigwinch 28)
442 (defconstant siglost 29)
443 (defconstant sigusr1 30)
444 (defconstant sigusr2 31))
445
446 (def-libc-call-out signal-ll
447 (:name "signal")
448 (:arguments (num int)
449 (handler (c-function (:language :stdc)
450 (:arguments (num int))
451 (:return-type))))
452 (:return-type ulong))
453
454 (def-libc-call-out signal-hack-ll
455 (:name "signal")
456 (:arguments (num int) (handler ulong))
457 (:return-type ulong))
458
459 (declaim (inline signal))
460 (defun signal (num func)
461 (if (functionp func)
462 (signal-ll num func)
463 (signal-hack-ll num func)))
464
465 ;;;
466 ;;; <unistd.h> -- getcwd
467 ;;;
468
469 (progn
470 (def-libc-call-out getcwd-ll
471 (:name "getcwd")
472 (:arguments (buf (c-ptr (c-array-max char 4096)) :out :alloca)
473 (size ulong))
474 (:return-type c-string))
475
476 (defun getcwd ()
477 (values (getcwd-ll 4096))))
478
479 ;;;
480 ;;; <unistd.h> -- fork, wait*, exec*
481 ;;;
482
483 (defun default-sigchld ()
484 (signal sigchld sig-dfl))
485
486 (def-libc-call-out fork
487 (:arguments)
488 (:return-type int))
489
490 (def-libc-call-out waitpid
491 (:arguments (pid int) (status (c-ptr int) :out) (options int))
492 (:return-type int))
493
494 (def-libc-call-out execvp
495 (:arguments (file c-string) (argv (c-array-ptr c-string)))
496 (:return-type int))
497
498 (def-libc-call-out _exit
499 (:arguments (status int))
500 (:return-type))
501
502 (defmacro wexitstatus (status) `(ash (logand ,status #xff00) -8))
503
504 ;;; if wifsignaled is true, gives the terminating signal
505 (defmacro wtermsig (status) `(logand ,status #x7f))
506
507 ;;; if wifstopped is true, gives signal that stopped child
508 (defmacro wstopsig (status) `(wexitstatus ,status))
509
510 (defmacro wifexited (status) `(zerop (wtermsig ,status)))
511
512 (defmacro wifsignaled (status) `(< 0 (logand ,status #x7f) 0x7f))
513
514 (defmacro wifsignaled (status) `(= (logand ,status #x7f) 0x7f))
515
516 (defconstant wnohang 1)
517 (defconstant wuntraced 2)
518 (defconstant wcontinued 3)
519
520 (defun spawn (name argument-vector)
521 (default-sigchld)
522 (let ((child (fork)))
523 (cond
524 ((< child 0) nil)
525 ((zerop child)
526 (execvp name argument-vector)
527 (_exit 1))
528 (t (loop
529 (multiple-value-bind (result status)
530 (waitpid child 0)
531 (if (or (>= result 0) (/= eintr errno))
532 (when (wifexited status)
533 (return (wexitstatus status)))
534 (return result))))))))
535
536 (defun run-program (name &key arguments)
537 (push name arguments)
538 (spawn name (coerce arguments 'vector)))
539
540 ;;;
541 ;;; Terminal related functions
542 ;;;
543
544 (defconstant l-ctermid 9)
545
546 (def-libc-call-out ctermid-ll
547 (:name "ctermid")
548 (:arguments (buf (c-ptr (c-array-max char 10)) :out))
549 (:return-type c-string))
550
551 (defun ctermid ()
552 (values (ctermid-ll)))
553
554 ;;;
555 ;;; <fcntl.h>
556 ;;;
557
558 (defconstant o-accmode #o00003)
559 (defconstant o-rdonly #o00000)
560 (defconstant o-wronly #o00001)
561 (defconstant o-rdwr #o00002)
562 (defconstant o-creat #o00100)
563 (defconstant o-excl #o00200)
564 (defconstant o-noctty #o00400)
565 (defconstant o-trunc #o01000)
566 (defconstant o-append #o02000)
567 (defconstant o-nonblock #o04000)
568 (defconstant o-sync #o10000)
569 (defconstant o-async #o20000)
570 (defconstant o-ndelay o-nonblock)
571 (defconstant o-fsync o-sync)

  ViewVC Help
Powered by ViewVC 1.1.5