206 lines
6.9 KiB
Scheme
206 lines
6.9 KiB
Scheme
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
|
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License version 3 as
|
|
;;; published by the Free Software Foundation.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
(library (ikarus posix)
|
|
(export posix-fork fork waitpid system file-exists? delete-file
|
|
nanosleep getenv env environ file-ctime current-directory)
|
|
(import
|
|
(rnrs bytevectors)
|
|
(except (ikarus)
|
|
nanosleep
|
|
posix-fork fork waitpid system file-exists? delete-file
|
|
getenv env environ file-ctime current-directory))
|
|
|
|
(define posix-fork
|
|
(lambda ()
|
|
(foreign-call "ikrt_fork")))
|
|
|
|
(define fork
|
|
(lambda (parent-proc child-proc)
|
|
(let ([pid (posix-fork)])
|
|
(cond
|
|
[(fx= pid 0) (child-proc)]
|
|
[(fx= pid -1)
|
|
(die 'fork "failed")]
|
|
[else (parent-proc pid)]))))
|
|
|
|
(define waitpid
|
|
(lambda (pid)
|
|
(unless (fixnum? pid)
|
|
(die 'waitpid "not a fixnum" pid))
|
|
(foreign-call "ikrt_waitpid" pid)))
|
|
|
|
(define system
|
|
(lambda (x)
|
|
(unless (string? x)
|
|
(die 'system "not a string" x))
|
|
(let ([rv (foreign-call "ik_system"
|
|
(string->utf8 x))])
|
|
(if (fx= rv -1)
|
|
(die 'system "failed")
|
|
rv))))
|
|
|
|
(define file-exists?
|
|
(lambda (x)
|
|
(unless (string? x)
|
|
(die 'file-exists? "filename is not a string" x))
|
|
(let ([v (foreign-call "ikrt_file_exists"
|
|
(string->utf8 x))])
|
|
(cond
|
|
[(boolean? v) v]
|
|
[else
|
|
(raise
|
|
(condition
|
|
(make-who-condition 'file-exists?)
|
|
(make-message-condition
|
|
(case v
|
|
[(1) "file path contains a non-directory"]
|
|
[(2) "file path is too long"]
|
|
[(3) "file path is not accessible"]
|
|
[(4) "file path contains too many symbolic links"]
|
|
[(5) "internal access error while accessing file"]
|
|
[(6) "IO error encountered while accessing file"]
|
|
[else "Unknown error while testing file"]))
|
|
(make-i/o-filename-error x)))]))))
|
|
|
|
(define delete-file
|
|
(lambda (x)
|
|
(unless (string? x)
|
|
(die 'delete-file "filename is not a string" x))
|
|
(let ([v (foreign-call "ikrt_delete_file"
|
|
(string->utf8 x))])
|
|
(case v
|
|
[(0) (void)]
|
|
[else
|
|
(raise
|
|
(condition
|
|
(make-who-condition 'delete-file)
|
|
(make-message-condition
|
|
(case v
|
|
[(1) "file path contains a non-directory"]
|
|
[(2) "file path is too long"]
|
|
[(3) "file does not exist"]
|
|
[(4) "file path is not accessible"]
|
|
[(5) "file path contains too many symbolic links"]
|
|
[(6) "you do not have permissions to delete file"]
|
|
[(7) "device is busy"]
|
|
[(8) "IO error encountered while deleting"]
|
|
[(9) "file is in a read-only file system"]
|
|
[(10) "internal access error while deleting"]
|
|
[else "Unknown error while deleting file"]))
|
|
(make-i/o-filename-error x)))]))))
|
|
|
|
(define (file-ctime x)
|
|
(define who 'file-ctime)
|
|
(unless (string? x)
|
|
(die who "not a string" x))
|
|
(let ([p (cons #f #f)])
|
|
(let ([v (foreign-call "ikrt_file_ctime" (string->utf8 x) p)])
|
|
(case v
|
|
[(0) (+ (* (car p) #e1e9) (cdr p))]
|
|
[else
|
|
(raise
|
|
(condition
|
|
(make-who-condition who)
|
|
(make-message-condition "cannot stat a file")
|
|
(make-i/o-filename-error x)))]))))
|
|
|
|
|
|
(define ($getenv-bv key)
|
|
(foreign-call "ikrt_getenv" key))
|
|
(define ($getenv-str key)
|
|
(utf8->string ($getenv-bv (string->utf8 key))))
|
|
|
|
(define (getenv key)
|
|
(if (string? key)
|
|
($getenv-str key)
|
|
(die 'getenv "the key is not a string" key)))
|
|
|
|
(define env
|
|
(let ()
|
|
(define env
|
|
(case-lambda
|
|
[(key)
|
|
(if (string? key)
|
|
(foreign-call "ikrt_getenv" key)
|
|
(die 'env "the key is not a string" key))]
|
|
[(key val) (env key val #t)]
|
|
[(key val overwrite?)
|
|
(if (string? key)
|
|
(if (string? val)
|
|
(unless (foreign-call "ikrt_setenv" key val overwrite?)
|
|
(die 'env "failed" key val))
|
|
(die 'env "the value is not a string" val))
|
|
(die 'env "the key is not a string" key))]))
|
|
(define busted (lambda args (die 'env "BUG: busted!")))
|
|
busted))
|
|
|
|
|
|
(define environ (lambda args (die 'environ "busted!")))
|
|
(define environ^
|
|
(lambda ()
|
|
(map
|
|
(lambda (s)
|
|
(define (loc= s i n)
|
|
(cond
|
|
[(fx= i n) i]
|
|
[(char=? (string-ref s i) #\=) i]
|
|
[else (loc= s (fx+ i 1) n)]))
|
|
(let ([n (string-length s)])
|
|
(let ([i (loc= s 0 n)])
|
|
(cons (substring s 0 i)
|
|
(if (fx< (fxadd1 i) n)
|
|
(substring s (fxadd1 i) n)
|
|
"")))))
|
|
(foreign-call "ikrt_environ"))))
|
|
|
|
(define (nanosleep secs nsecs)
|
|
(import (ikarus system $fx))
|
|
(unless (cond
|
|
[(fixnum? secs) ($fx>= secs 0)]
|
|
[(bignum? secs) (<= 0 secs (- (expt 2 32) 1))]
|
|
[else (die 'nanosleep "not an exact integer" secs)])
|
|
(die 'nanosleep "seconds must be a nonnegative integer <=" secs))
|
|
(unless (cond
|
|
[(fixnum? nsecs) ($fx>= nsecs 0)]
|
|
[(bignum? nsecs) (<= 0 nsecs 999999999)]
|
|
[else (die 'nanosleep "not an exact integer" nsecs)])
|
|
(die 'nanosleep "nanoseconds must be an integer \
|
|
in the range 0..999999999" nsecs))
|
|
(let ([rv (foreign-call "ikrt_nanosleep" secs nsecs)])
|
|
(unless (eq? rv 0)
|
|
(error 'nanosleep "failed"))))
|
|
|
|
|
|
(define current-directory
|
|
(case-lambda
|
|
[()
|
|
(let ([v (foreign-call "ikrt_getcwd")])
|
|
(if (bytevector? v)
|
|
(utf8->string v)
|
|
(die 'current-directory
|
|
"failed to get current directory")))]
|
|
[(x)
|
|
(if (string? x)
|
|
(let ([rv (foreign-call "ikrt_chdir" (string->utf8 x))])
|
|
(unless (eq? rv 0)
|
|
(die 'current-directory
|
|
"failed to set current directory")))
|
|
(die 'current-directory "not a string" x))]))
|
|
|
|
|
|
)
|