/[meta-cvs]/meta-cvs/F-258A1D35AE34AADD34D34F5A328405CC.lisp
ViewVC logotype

Diff of /meta-cvs/F-258A1D35AE34AADD34D34F5A328405CC.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by kaz, Fri Sep 6 02:17:27 2002 UTC revision 1.5.2.7 by kaz, Mon Jul 26 05:33:27 2004 UTC
# Line 2  Line 2 
2  ;;; which is distributed under the GNU license.  ;;; which is distributed under the GNU license.
3  ;;; Copyright 2002 Kaz Kylheku  ;;; Copyright 2002 Kaz Kylheku
4    
5    (push :clisp-unix-funcs *features*)
6    
7  (defpackage :unix-funcs  (defpackage :unix-funcs
8    (:use :ffi :lisp)    (:use :common-lisp)
9    (:shadow :open :close)    (:shadowing-import-from :ffi
10    (:export :null-pointer-p :errno :strerror :eperm :enoent :esrch :eintr :eio      :def-call-out :def-c-struct :c-array-max :c-pointer :c-ptr :c-string :int
11             :enxio :e2big :enoexec :ebadf :echild :eagain :enomem :eacces      :uint :ulong :boolean :character :c-array-ptr)
12             :efault :enotblk :ebusy :eexist :exdev :enodev :enotdir :eisdir    (:shadow
13             :einval :enfile :emfile :enotty :etxtbsy :efbig :enospc :espipe      :open :close)
14             :erofs :emlink :epipe :edom :erange :edeadlk :enametoolong :enolck    (:intern
15             :enosys :enotempty :eloop :ewouldblock :dirent :opendir :closedir      :def-c-call-out)
16             :readdir :ino :name :open :close :chdir :fchdir :link :symlink    (:export
17             :readlink :unlink :rmdir :stat :stat :lstat :fstat :chmod      :null-pointer-p :errno :strerror :eperm :enoent :esrch :eintr :eio
18             :mode :nlink :uid      :enxio :e2big :enoexec :ebadf :echild :eagain :enomem :eacces
19             :gid :rdev :blksize :blocks :atime :mtime :ctime :s-ifmt :s-ifdir      :efault :enotblk :ebusy :eexist :exdev :enodev :enotdir :eisdir
20             :s-ifchr :s-ifblk :s-ifreg :s-ififo :s-iflnk :s-ifsock :s-isdir      :einval :enfile :emfile :enotty :etxtbsy :efbig :enospc :espipe
21             :s-ischr :s-isblk :s-isreg :s-isfifo :s-islnk :s-issock :s-isuid      :erofs :emlink :epipe :edom :erange :edeadlk :enametoolong :enolck
22             :s-isgid :s-isvtx :s-iread :s-iwrite :s-iexec :s-irusr :s-iwusr      :enosys :enotempty :eloop :ewouldblock :dirent :opendir :closedir
23             :s-ixusr :s-irwxu :s-irgrp :s-iwgrp :s-ixgrp :s-irwxg :s-iroth      :readdir :ino :name :open :close :chdir :fchdir :link :symlink
24             :s-iwoth :s-ixoth :s-irwxo :accessperms :deffilemode :o-accmode      :readlink :unlink :rmdir :stat :stat :lstat :fstat :chmod
25             :o-rdonly :o-wronly :o-rdwr :o-creat :o-excl :o-noctty :o-trunc      :mode :nlink :uid
26             :o-append :o-nonblock :o-sync :o-async :o-ndelay :o-fsync :getcwd))      :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)  (in-package :unix-funcs)
37    
38  (push :clisp-unix-funcs *features*)  (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  ;;; Null pointer test, needed in CLISP 2.27 and older.  ;;; Null pointer test, needed in CLISP 2.27 and older.
54  ;;;  ;;;
55    
56  (def-c-call-out null-pointer-p  (def-c-call-out null-pointer-p
57    (:name "impl_null_pointer_p")    (:name "mcvs_null_pointer_p")
58    (:arguments (pointer c-pointer))    (:arguments (pointer c-pointer))
59    (:return-type boolean))    (:return-type boolean))
60    
# Line 41  Line 63 
63  ;;;  ;;;
64    
65  (def-c-call-out get-errno  (def-c-call-out get-errno
66    (:name "impl_get_errno")    (:name "mcvs_get_errno")
67    (:arguments)    (:arguments)
68    (:return-type int))    (:return-type int))
69    
70  (def-c-call-out set-errno  (def-c-call-out set-errno
71    (:name "impl_set_errno")    (:name "mcvs_set_errno")
72    (:arguments (value int))    (:arguments (value int))
73    (:return-type int))    (:return-type int))
74    
# Line 116  Line 138 
138    (:return-type int))    (:return-type int))
139    
140  (def-c-call-out readdir  (def-c-call-out readdir
141    (:name "impl_readdir")    (:name "mcvs_readdir")
142    (:arguments (dirp c-pointer))    (:arguments (dirp c-pointer))
143    (:return-type (c-ptr dirent)))    (:return-type (c-ptr dirent)))
144    
# Line 161  Line 183 
183    (:return-type int))    (:return-type int))
184    
185  (def-c-call-out readlink  (def-c-call-out readlink
186    (:name "impl_readlink")    (:name "mcvs_readlink")
187    (:arguments (path c-string))    (:arguments (path c-string))
188    (:return-type c-string :malloc-free))    (:return-type c-string :malloc-free))
189    
# Line 192  Line 214 
214    (ctime ulong))    (ctime ulong))
215    
216  (def-c-call-out stat  (def-c-call-out stat
217    (:name "impl_stat")    (:name "mcvs_stat")
218    (:arguments (name c-string)    (:arguments (name c-string)
219                (buf (c-ptr stat) :out))                (buf (c-ptr stat) :out))
220    (:return-type int))    (:return-type int))
221    
222  (def-c-call-out lstat  (def-c-call-out lstat
223    (:name "impl_lstat")    (:name "mcvs_lstat")
224    (:arguments (name c-string)    (:arguments (name c-string)
225                (buf (c-ptr stat) :out))                (buf (c-ptr stat) :out))
226    (:return-type int))    (:return-type int))
227    
228  (def-c-call-out fstat  (def-c-call-out fstat
229    (:name "impl_fstat")    (:name "mcvs_fstat")
230    (:arguments (fd int)    (:arguments (fd int)
231                (buf (c-ptr stat) :out))                (buf (c-ptr stat) :out))
232    (:return-type int))    (:return-type int))
# Line 257  Line 279 
279    
280  ;;;  ;;;
281  ;;; <unistd.h> -- getcwd  ;;; <unistd.h> -- getcwd
282    ;;;
283    
284  (def-c-call-out getcwd  (def-c-call-out getcwd
285    (:name "impl_getcwd")    (:name "mcvs_getcwd")
286      (:arguments)
287      (:return-type c-string :malloc-free))
288    
289    ;;;
290    ;;; <unistd.h> -- fork, wait*, exec*
291    ;;;
292    
293    (def-c-call-out default-sigchld
294      (:name "mcvs_default_sigchld"))
295    
296    (def-c-call-out spawn
297      (:name "mcvs_spawn")
298      (:arguments (name c-string)
299                  (argv (c-array-ptr c-string) :in :malloc-free))
300      (:return-type int))
301    
302    (defun run-program (name &key arguments)
303      (push name arguments)
304      (spawn name (coerce arguments 'vector)))
305    
306    ;;;
307    ;;; Terminal related functions
308    ;;;
309    
310    (def-c-call-out ctermid
311      (:name "mcvs_ctermid")
312    (:arguments)    (:arguments)
313    (:return-type c-string :malloc-free))    (:return-type c-string :malloc-free))
314    

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.5.2.7

  ViewVC Help
Powered by ViewVC 1.1.5