/[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.13 - (show annotations)
Sat Dec 11 07:58:05 2004 UTC (9 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.12: +1 -10 lines
Get rid of CLISP 2.27 support.

* code/unix-bindings/unix.lisp (null-pointer-p): Function removed.

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

  ViewVC Help
Powered by ViewVC 1.1.5