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

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

Initial import of chicken3 code

File size: 3.1 KB
Line 
1
2;; Things that the posix unit forgot
3(foreign-declare #<<EOF
4
5#include <sys/stat.h>
6#include <utime.h>
7
8double C_utime_atime;
9double C_utime_mtime;
10struct utimbuf C_utime_buf;
11
12#define C_lchmod(fn, m)      C_fix(lchmod(C_data_pointer(fn), C_unfix(m)))
13#define C_lchown(fn, u, g)   C_fix(lchown(C_data_pointer(fn), C_unfix(u), C_unfix(g)))
14#define C_mknod(fn, m, d) C_fix(mknod(C_data_pointer(fn), C_unfix(m), C_unfix(d)))
15#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)))
16EOF
17)
18
19(define-foreign-variable _utime_atime double "C_utime_atime")
20(define-foreign-variable _utime_mtime double "C_utime_mtime")
21
22(define posix-error
23  (let ([strerror (foreign-lambda c-string "strerror" int)]
24        [string-append string-append] )
25    (lambda (type loc msg . args)
26      (let ([rn (##sys#update-errno)])
27        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
28
29
30(define-foreign-variable _s_ifmt int "S_IFMT")
31(define stat/ifmt _s_ifmt)
32
33(define-foreign-variable _s_ififo int "S_IFIFO")
34(define stat/ififo _s_ififo)
35(define-foreign-variable _s_ifchr int "S_IFCHR")
36(define stat/ifchr _s_ifchr)
37(define-foreign-variable _s_ifdir int "S_IFDIR")
38(define stat/ifdir _s_ifdir)
39(define-foreign-variable _s_ifblk int "S_IFBLK")
40(define stat/ifblk _s_ifblk)
41(define-foreign-variable _s_ifreg int "S_IFREG")
42(define stat/ifreg _s_ifreg)
43(define-foreign-variable _s_iflnk int "S_IFLNK")
44(define stat/iflnk _s_iflnk)
45(define-foreign-variable _s_ifsock int "S_IFSOCK")
46(define stat/ifsock _s_ifsock)
47
48(define change-link-mode
49   (lambda (fname m)
50      (##sys#check-string fname 'change-link-mode)
51      (##sys#check-exact m 'change-link-mode)
52      (when (fx< (##core#inline "C_lchmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
53         (posix-error #:file-error 'change-link-mode "cannot change link mode" fname m))))
54
55(define change-link-owner
56   (lambda (fn uid gid)
57      (##sys#check-string fn 'change-link-owner)
58      (##sys#check-exact uid 'change-link-owner)
59      (##sys#check-exact gid 'change-link-owner)
60      (when (fx< (##core#inline "C_lchown" (##sys#make-c-string (##sys#expand-home-path fn)) uid gid) 0)
61         (posix-error #:file-error 'change-link-owner "cannot change link owner" fn uid gid))))
62
63(define create-special-file
64   (lambda (fn mode devnum)
65      (##sys#check-string fn 'change-link-owner)
66      (##sys#check-exact mode 'change-link-owner)
67      (##sys#check-exact devnum 'change-link-owner)
68      (when (fx< (##core#inline "C_mknod" (##sys#make-c-string (##sys#expand-home-path fn)) mode devnum) 0)
69         (posix-error #:file-error 'make-special-file "cannot make special file" fn mode devnum))))
70
71(define (change-file-times fn atime mtime)
72   (##sys#check-string fn 'change-file-times)
73   (##sys#check-number atime 'change-file-times)
74   (##sys#check-number mtime 'change-file-times)
75   
76   (set! _utime_atime atime)
77   (set! _utime_mtime mtime)
78   
79   (when (fx< (##core#inline "C_utime" (##sys#make-c-string (##sys#expand-home-path fn))) 0)
80      (posix-error #:file-error 'change-file-times "cannot change file times" fn atime mtime)))
81   
82   
Note: See TracBrowser for help on using the repository browser.