/[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.14 - (show annotations)
Fri Nov 24 04:08:24 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.13: +261 -95 lines
Rewrote the CLISP bindings. The CLISP FFI is used to directly
access the glibc shared library on Linux. This completely eliminates
the need to create a custom linking set. Meta-CVS can now be built
without any C development tools. The downside is that the the FFI
definitions are not portable, since they depend on the glibc ABI.
Support for other C libraries has to be hacked in the clisp-ffi.lisp
module now. The main() hack is gone now too.

* code/unix-bindings/link.sh: Removed.
* code/unix-bindings/Makefile: Likewise.
* code/unix-bindings/wrap.c: Likewise.

* code/unix-bindings/unix.lisp: Renamed to
code/unix-bindings/clisp-ffi.lisp. Contains revamped FFI definitions
targetting Linux glibc.

* code/install.sh: Substantially simplified. No longer builds a CLISP
linking set. No longer builds the mcvs-upgrade tool, which is not
useful any longer. Error tests eliminated with use of ``set -e''.

* code/mcvs.lisp: Updated to load everything properly.
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 (pushnew :linux-libc6 *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 :foreign-address-null
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
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 #+linux-libc6
46 (defmacro def-libc-call-out (name &rest args)
47 `(def-call-out ,name (:language :stdc) (:library "libc.so.6") ,@args))
48
49 ;;;
50 ;;; Null pointer test on foreign objects.
51 ;;;
52
53 (defun null-pointer-p (ptr)
54 (foreign-address-null ptr))
55
56 ;;;
57 ;;; <errno.h>
58 ;;;
59
60 #+linux-libc6
61 (progn
62 (def-libc-call-out errno-location
63 (:name "__errno_location")
64 (:arguments)
65 (:return-type (c-pointer int)))
66
67 (defun get-errno ()
68 (let ((loc (errno-location)))
69 (foreign-value loc)))
70
71 (defun set-errno (value)
72 (let ((loc (errno-location)))
73 (setf (foreign-value loc) value)))
74
75 (defsetf get-errno set-errno)
76
77 (define-symbol-macro errno (get-errno)))
78
79 (def-libc-call-out strerror
80 (:arguments (errnum int))
81 (:return-type c-string :none))
82
83 (defconstant eperm 1)
84 (defconstant enoent 2)
85 (defconstant esrch 3)
86 (defconstant eintr 4)
87 (defconstant eio 5)
88 (defconstant enxio 6)
89 (defconstant e2big 7)
90 (defconstant enoexec 8)
91 (defconstant ebadf 9)
92 (defconstant echild 10)
93 (defconstant eagain 11)
94 (defconstant enomem 12)
95 (defconstant eacces 13)
96 (defconstant efault 14)
97 (defconstant enotblk 15)
98 (defconstant ebusy 16)
99 (defconstant eexist 17)
100 (defconstant exdev 18)
101 (defconstant enodev 19)
102 (defconstant enotdir 20)
103 (defconstant eisdir 21)
104 (defconstant einval 22)
105 (defconstant enfile 23)
106 (defconstant emfile 24)
107 (defconstant enotty 25)
108 (defconstant etxtbsy 26)
109 (defconstant efbig 27)
110 (defconstant enospc 28)
111 (defconstant espipe 29)
112 (defconstant erofs 30)
113 (defconstant emlink 31)
114 (defconstant epipe 32)
115 (defconstant edom 33)
116 (defconstant erange 34)
117 (defconstant edeadlk 35)
118 (defconstant enametoolong 36)
119 (defconstant enolck 37)
120 (defconstant enosys 38)
121 (defconstant enotempty 39)
122 (defconstant eloop 40)
123 (defconstant ewouldblock eagain)
124
125 ;;;
126 ;;; <dirent.h>
127 ;;;
128
129 #+linux-libc6
130 (def-c-struct dirent
131 ;; Actually this is struct dirent64
132 (ino uint64)
133 (off uint64)
134 (reclen uint16)
135 (type uint8)
136 (name (c-array-max character 256)))
137
138 (def-libc-call-out opendir
139 (:arguments (name c-string))
140 (:return-type c-pointer))
141
142 (def-libc-call-out closedir
143 (:arguments (dirp c-pointer))
144 (:return-type int))
145
146 #+linux-libc6
147 (progn
148 (def-libc-call-out readdir
149 (:name "readdir64")
150 (:arguments (dirp c-pointer))
151 (:return-type (c-ptr dirent))))
152
153
154
155 ;;;
156 ;;; <unistd.h> -- open, close
157 ;;;
158
159 (def-libc-call-out open
160 (:arguments (name c-string)
161 (flags int)
162 (mode uint))
163 (:return-type int))
164
165 (def-libc-call-out close
166 (:arguments (fd int))
167 (:return-type int))
168
169 ;;;
170 ;;; <unistd.h> -- chdir, fchdir
171 ;;;
172
173 (def-libc-call-out chdir
174 (:arguments (path c-string))
175 (:return-type int))
176
177 (def-libc-call-out fchdir
178 (:arguments (fd int))
179 (:return-type int))
180
181 ;;;
182 ;;; <unistd.h> -- link, symlink, readlink, unlink, rmdir
183
184
185 (def-libc-call-out link
186 (:arguments (from c-string)
187 (to c-string))
188 (:return-type int))
189
190 (def-libc-call-out symlink
191 (:arguments (from c-string)
192 (to c-string))
193 (:return-type int))
194
195 (def-libc-call-out readlink-ll
196 (:name "readlink")
197 (:arguments (path c-string)
198 (buf (c-ptr (c-array-max character 4096)) :out :alloca)
199 (size ulong))
200 (:return-type int))
201
202 (defun readlink (path)
203 (multiple-value-bind (result link)
204 (readlink-ll path 4096)
205 (if (> result 0) (coerce link 'string) nil)))
206
207 (def-libc-call-out unlink
208 (:arguments (path c-string))
209 (:return-type int))
210
211 (def-libc-call-out rmdir
212 (:arguments (path c-string))
213 (:return-type int))
214
215 ;;;
216 ;;; <unistd.h> -- stat, lstat, chmod
217 ;;;
218
219 #+linux-libc6
220 (def-c-struct stat
221 ;; actually, this is stat64
222 (dev uint64)
223 (__pad0 uint16)
224 (__ino uint32)
225 (mode uint32)
226 (nlink uint32)
227 (uid uint32)
228 (gid uint32)
229 (rdev uint64)
230 (__pad1 uint16)
231 (size uint64)
232 (blksize long)
233 (blocks uint64)
234 (atime uint32)
235 (atime-nsec uint32)
236 (mtime uint32)
237 (mtime-nsec uint32)
238 (ctime uint32)
239 (ctime-nsec uint32)
240 (ino uint64))
241
242 #+linux-libc6
243 (progn
244 (defconstant stat-ver 3)
245
246 (def-libc-call-out __xstat64
247 (:arguments (version int)
248 (name c-string)
249 (buf (c-ptr stat) :out))
250 (:return-type int))
251
252 (def-libc-call-out __lxstat64
253 (:arguments (version int)
254 (name c-string)
255 (buf (c-ptr stat) :out))
256 (:return-type int))
257
258 (def-libc-call-out __fxstat64
259 (:arguments (version int)
260 (fd int)
261 (buf (c-ptr stat) :out))
262 (:return-type int))
263
264 (declaim (inline stat) (inline fstat) (inline lstat))
265
266 (defun stat (name) (__xstat64 stat-ver name))
267 (defun fstat (name) (__fxstat64 stat-ver name))
268 (defun lstat (name) (__lxstat64 stat-ver name)))
269
270 (def-libc-call-out chmod
271 (:arguments (name c-string)
272 (mode uint))
273 (:return-type int))
274
275 (defconstant s-ifmt #o170000)
276 (defconstant s-ifdir #o040000)
277 (defconstant s-ifchr #o020000)
278 (defconstant s-ifblk #o060000)
279 (defconstant s-ifreg #o100000)
280 (defconstant s-ififo #o010000)
281 (defconstant s-iflnk #o120000)
282 (defconstant s-ifsock #o140000)
283
284 (defmacro s-isdir (m) `(= (logand ,m s-ifmt) s-ifdir))
285 (defmacro s-ischr (m) `(= (logand ,m s-ifmt) s-ifchr))
286 (defmacro s-isblk (m) `(= (logand ,m s-ifmt) s-ifblk))
287 (defmacro s-isreg (m) `(= (logand ,m s-ifmt) s-ifreg))
288 (defmacro s-isfifo (m) `(= (logand ,m s-ifmt) s-iffifo))
289 (defmacro s-islnk (m) `(= (logand ,m s-ifmt) s-iflnk))
290 (defmacro s-issock (m) `(= (logand ,m s-ifmt) s-ifsock))
291
292 (defconstant s-isuid #o004000)
293 (defconstant s-isgid #o002000)
294 (defconstant s-isvtx #o001000)
295
296 (define-symbol-macro s-iread s-irusr)
297 (define-symbol-macro s-iwrite s-iwusr)
298 (define-symbol-macro s-iexec s-ixusr)
299
300 (defconstant s-irusr #o000400)
301 (defconstant s-iwusr #o000200)
302 (defconstant s-ixusr #o000100)
303 (defconstant s-irwxu (logior s-irusr s-iwusr s-ixusr))
304 (defconstant s-irgrp #o000040)
305 (defconstant s-iwgrp #o000020)
306 (defconstant s-ixgrp #o000010)
307 (defconstant s-irwxg (logior s-irgrp s-iwgrp s-ixgrp))
308 (defconstant s-iroth #o000004)
309 (defconstant s-iwoth #o000002)
310 (defconstant s-ixoth #o000001)
311 (defconstant s-irwxo (logior s-iroth s-iwoth s-ixoth))
312
313 (defconstant accessperms (logior s-irwxu s-irwxg s-irwxo))
314 (defconstant deffilemode (logior s-irusr s-iwusr s-irgrp s-iwgrp s-iroth s-iwoth))
315
316 ;;;
317 ;;; <signal.h>
318 ;;;
319
320
321 #+linux-libc6
322 (progn
323 (defconstant sig-err -1)
324 (defconstant sig-dfl 0)
325 (defconstant sig-ign 1))
326
327 (defconstant sighup 1)
328 (defconstant sigint 2)
329 (defconstant sigquit 3)
330 (defconstant sigill 4)
331 (defconstant sigtrap 5)
332 (defconstant sigabrt 6)
333 (defconstant sigiot 6)
334 (defconstant sigbus 7)
335 (defconstant sigfpe 8)
336 (defconstant sigkill 9)
337 (defconstant sigusr1 10)
338 (defconstant sigsegv 11)
339 (defconstant sigusr2 12)
340 (defconstant sigpipe 13)
341 (defconstant sigalrm 14)
342 (defconstant sigterm 15)
343 (defconstant sigstkflt 16)
344 (defconstant sigchld 17)
345 (defconstant sigcld sigchld)
346 (defconstant sigcont 18)
347 (defconstant sigstop 19)
348 (defconstant sigtstp 20)
349 (defconstant sigttin 21)
350 (defconstant sigttou 22)
351 (defconstant sigurg 23)
352 (defconstant sigxcpu 24)
353 (defconstant sigxfsz 25)
354 (defconstant sigvtalrm 26)
355 (defconstant sigprof 27)
356 (defconstant sigwinch 28)
357 (defconstant sigio 29)
358 (defconstant sigpoll sigio)
359 (defconstant sigpwr 30)
360 (defconstant sigsys 31)
361 (defconstant sigunused 31)
362
363 (def-libc-call-out signal-ll
364 (:name "signal")
365 (:arguments (num int)
366 (handler (c-function (:language :stdc)
367 (:arguments (num int))
368 (:return-type))))
369 (:return-type ulong))
370
371 (def-libc-call-out signal-hack-ll
372 (:name "signal")
373 (:arguments (num int) (handler ulong))
374 (:return-type ulong))
375
376 (declaim (inline signal))
377 (defun signal (num func)
378 (if (functionp func)
379 (signal-ll num func)
380 (signal-hack-ll num func)))
381
382 ;;;
383 ;;; <unistd.h> -- getcwd
384 ;;;
385
386 #+linux-libc6
387 (progn
388 (def-libc-call-out getcwd-ll
389 (:name "getcwd")
390 (:arguments (buf (c-ptr (c-array-max char 4096)) :out :alloca)
391 (size ulong))
392 (:return-type c-string))
393
394 (defun getcwd ()
395 (values (getcwd-ll 4096))))
396
397 ;;;
398 ;;; <unistd.h> -- fork, wait*, exec*
399 ;;;
400
401 (defun default-sigchld ()
402 (signal sigchld sig-dfl))
403
404 (def-libc-call-out fork
405 (:arguments)
406 (:return-type int))
407
408 (def-libc-call-out waitpid
409 (:arguments (pid int) (status (c-ptr int) :out) (options int))
410 (:return-type int))
411
412 (def-libc-call-out execvp
413 (:arguments (file c-string) (argv (c-array-ptr c-string)))
414 (:return-type int))
415
416 (def-libc-call-out _exit
417 (:arguments (status int))
418 (:return-type))
419
420 (defmacro wexitstatus (status) `(ash (logand ,status #xff00) -8))
421
422 ;;; if wifsignaled is true, gives the terminating signal
423 (defmacro wtermsig (status) `(logand ,status #x7f))
424
425 ;;; if wifstopped is true, gives signal that stopped child
426 (defmacro wstopsig (status) `(wexitstatus ,status))
427
428 (defmacro wifexited (status) `(zerop (wtermsig ,status)))
429
430 (defmacro wifsignaled (status) `(< 0 (logand ,status #x7f) 0x7f))
431
432 (defmacro wifsignaled (status) `(= (logand ,status #x7f) 0x7f))
433
434 (defconstant wnohang 1)
435 (defconstant wuntraced 2)
436 (defconstant wcontinued 3)
437
438 (defun spawn (name argument-vector)
439 (default-sigchld)
440 (let ((child (fork)))
441 (cond
442 ((< child 0) nil)
443 ((zerop child)
444 (execvp name argument-vector)
445 (_exit 1))
446 (t (loop
447 (multiple-value-bind (result status)
448 (waitpid child 0)
449 (if (or (>= 0 result) (/= eintr errno))
450 (when (wifexited status)
451 (return (wexitstatus status)))
452 (return result))))))))
453
454 (defun run-program (name &key arguments)
455 (push name arguments)
456 (spawn name (coerce arguments 'vector)))
457
458 ;;;
459 ;;; Terminal related functions
460 ;;;
461
462 (defconstant l-ctermid 9)
463
464 (def-libc-call-out ctermid-ll
465 (:name "ctermid")
466 (:arguments (buf (c-ptr (c-array-max char 10)) :out))
467 (:return-type c-string))
468
469 (defun ctermid ()
470 (values (ctermid-ll)))
471
472 ;;;
473 ;;; <fcntl.h>
474 ;;;
475
476 (defconstant o-accmode #o00003)
477 (defconstant o-rdonly #o00000)
478 (defconstant o-wronly #o00001)
479 (defconstant o-rdwr #o00002)
480 (defconstant o-creat #o00100)
481 (defconstant o-excl #o00200)
482 (defconstant o-noctty #o00400)
483 (defconstant o-trunc #o01000)
484 (defconstant o-append #o02000)
485 (defconstant o-nonblock #o04000)
486 (defconstant o-sync #o10000)
487 (defconstant o-async #o20000)
488 (defconstant o-ndelay o-nonblock)
489 (defconstant o-fsync o-sync)

  ViewVC Help
Powered by ViewVC 1.1.5