source: project/release/4/ugarit/trunk/posixextras.scm @ 15242

Last change on this file since 15242 was 15242, checked in by Alaric Snell-Pym, 11 years ago

C-Keen's patches

File size: 4.2 KB
Line 
1(import foreign)
2
3;; Things that the posix unit forgot
4(foreign-declare #<<EOF
5
6#include <sys/stat.h>
7#include <utime.h>
8
9double C_utime_atime;
10double C_utime_mtime;
11struct utimbuf C_utime_buf;
12
13#define C_lchmod(fn, m)      C_fix(lchmod(C_data_pointer(fn), C_unfix(m)))
14#define C_lchown(fn, u, g)   C_fix(lchown(C_data_pointer(fn), C_unfix(u), C_unfix(g)))
15#define C_mknod(fn, m, d) C_fix(mknod(C_data_pointer(fn), C_unfix(m), C_unfix(d)))
16#define C_utime(fn) C_fix((C_utime_buf.actime = C_utime_atime, C_utime_buf.modtime = C_utime_mtime, utime(C_data_pointer(fn), &C_utime_buf)))
17#define C_ftell(p) C_fix(ftell(C_port_file(p)))
18#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
19#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
20EOF
21)
22
23(define-foreign-variable _utime_atime double "C_utime_atime")
24(define-foreign-variable _utime_mtime double "C_utime_mtime")
25
26(define posix-error
27  (let ([strerror (foreign-lambda c-string "strerror" int)]
28        [string-append string-append] )
29    (lambda (type loc msg . args)
30      (let ([rn (##sys#update-errno)])
31        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
32
33
34(define-foreign-variable _s_ifmt int "S_IFMT")
35(define stat/ifmt _s_ifmt)
36
37(define-foreign-variable _s_ififo int "S_IFIFO")
38(define stat/ififo _s_ififo)
39(define-foreign-variable _s_ifchr int "S_IFCHR")
40(define stat/ifchr _s_ifchr)
41(define-foreign-variable _s_ifdir int "S_IFDIR")
42(define stat/ifdir _s_ifdir)
43(define-foreign-variable _s_ifblk int "S_IFBLK")
44(define stat/ifblk _s_ifblk)
45(define-foreign-variable _s_ifreg int "S_IFREG")
46(define stat/ifreg _s_ifreg)
47(define-foreign-variable _s_iflnk int "S_IFLNK")
48(define stat/iflnk _s_iflnk)
49(define-foreign-variable _s_ifsock int "S_IFSOCK")
50(define stat/ifsock _s_ifsock)
51
52(define change-link-mode
53   (lambda (fname m)
54      (##sys#check-string fname 'change-link-mode)
55      (##sys#check-exact m 'change-link-mode)
56      (when (fx< (##core#inline "C_lchmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
57         (posix-error #:file-error 'change-link-mode "cannot change link mode" fname m))))
58
59(define change-link-owner
60   (lambda (fn uid gid)
61      (##sys#check-string fn 'change-link-owner)
62      (##sys#check-exact uid 'change-link-owner)
63      (##sys#check-exact gid 'change-link-owner)
64      (when (fx< (##core#inline "C_lchown" (##sys#make-c-string (##sys#expand-home-path fn)) uid gid) 0)
65         (posix-error #:file-error 'change-link-owner "cannot change link owner" fn uid gid))))
66
67(define create-special-file
68   (lambda (fn mode devnum)
69      (##sys#check-string fn 'change-link-owner)
70      (##sys#check-exact mode 'change-link-owner)
71      (##sys#check-exact devnum 'change-link-owner)
72      (when (fx< (##core#inline "C_mknod" (##sys#make-c-string (##sys#expand-home-path fn)) mode devnum) 0)
73         (posix-error #:file-error 'make-special-file "cannot make special file" fn mode devnum))))
74
75(define (change-file-times fn atime mtime)
76   (##sys#check-string fn 'change-file-times)
77   (##sys#check-number atime 'change-file-times)
78   (##sys#check-number mtime 'change-file-times)
79   
80   (set! _utime_atime atime)
81   (set! _utime_mtime mtime)
82   
83   (when (fx< (##core#inline "C_utime" (##sys#make-c-string (##sys#expand-home-path fn))) 0)
84      (posix-error #:file-error 'change-file-times "cannot change file times" fn atime mtime)))
85   
86 
87(define-foreign-variable _seek_set int "SEEK_SET")
88(define-foreign-variable _seek_cur int "SEEK_CUR")
89(define-foreign-variable _seek_end int "SEEK_END")
90 
91(define set-file-position!
92   (lambda (port pos . whence)
93     (let ([whence (if (pair? whence) (car whence) _seek_set)])
94       (##sys#check-exact pos 'set-file-position!)
95       (##sys#check-exact whence 'set-file-position!)
96       (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
97       (unless (cond [(port? port)
98     (and (eq? (##sys#slot port 7) 'stream)
99       (##core#inline "C_fseek" port pos whence) ) ]
100     [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
101     [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
102   (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
103
Note: See TracBrowser for help on using the repository browser.