suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add #:save-errno option for foreign-function types

Browse Source 
svn: r17299

original commit: 87f05fed9597a6355b33bcaeeb1ace67987cdb1a
This commit is contained in:
Matthew Flatt 2009-12-14 23:52:23 +00:00
commit 2ecaa89a71
1 changed files with 20 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/mzlib/os.ss
View File

@ -80,21 +80,27 @@
;; open : string int -> int ;; open : string int -> int
(define open (define open
(delay-ffi-obj (winize "open") #f (_fun _string _int -> _int))) (delay-ffi-obj (winize "open") #f (_fun #:save-errno 'posix _string _int -> _int)))
;; close : int -> int ;; close : int -> int
(define close (define close
(delay-ffi-obj (winize "close") #f (_fun _int -> _int))) (delay-ffi-obj (winize "close") #f (_fun #:save-errno 'posix _int -> _int)))
;; ftruncate : int int -> int ;; ftruncate : int int -> int
(define ftruncate (define ftruncate
(if (eq? 'windows (system-type)) (if (eq? 'windows (system-type))
(delay-ffi-obj "_chsize" #f (_fun _int _llong -> _int)) (delay-ffi-obj "_chsize" #f (_fun #:save-errno 'posix _int _llong -> _int))
(delay-ffi-obj "ftruncate" #f (_fun _int _llong -> _int)))) (delay-ffi-obj "ftruncate" #f (_fun #:save-errno 'posix _int _llong -> _int))))
;; on-c-fail : int (-> X) int or X ;; on-c-fail : int (-> X) int or X
(define (on-c-fail val fail-k) (define (on-c-fail thunk fail-k)
(if (> val -1) val (fail-k))) (let ([val (thunk)])
(cond
[(> val -1) val]
[(= (saved-errno) (lookup-errno 'EINTR))
;; interrupted by a signal; retry
(on-c-fail thunk fail-k)]
[else (fail-k)])))
(define scheme_security_check_file (define scheme_security_check_file
(delay-ffi-obj "scheme_security_check_file" #f (delay-ffi-obj "scheme_security_check_file" #f
@ -115,15 +121,20 @@
(if (path? file) (path->string file) file) (if (path? file) (path->string file) file)
SCHEME_GUARD_FILE_WRITE) SCHEME_GUARD_FILE_WRITE)
(let ([fd (on-c-fail (let ([fd (on-c-fail
((force open) file O_WRONLY) (lambda ()
((force open) file O_WRONLY))
(lambda () (lambda ()
(error 'truncate-file "could not open file")))]) (error 'truncate-file "could not open file")))])
(on-c-fail (on-c-fail
((force ftruncate) fd size) (lambda ()
((force ftruncate) fd size))
(lambda () (lambda ()
((force close) fd) ((force close) fd)
(error 'truncate-file "could not truncate file"))) (error 'truncate-file "could not truncate file")))
((force close) fd) (on-c-fail
(lambda ()
((force close) fd))
void)
(void)))) (void))))
(provide truncate-file) (provide truncate-file)