;;; 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 file-regular? file-directory? file-symbolic-link? make-symbolic-link directory-list make-directory delete-directory change-mode strerror) (import (rnrs bytevectors) (except (ikarus) nanosleep posix-fork fork waitpid system file-exists? delete-file getenv env environ file-ctime current-directory file-regular? file-directory? file-symbolic-link? make-symbolic-link directory-list make-directory delete-directory change-mode strerror)) (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 0) (raise/strerror 'fork pid)] [else (parent-proc pid)])))) (define waitpid (lambda (pid) (unless (fixnum? pid) (die 'waitpid "not a fixnum" pid)) (let ([r (foreign-call "ikrt_waitpid" pid)]) (if (fx< r 0) (raise/strerror 'waitpid r) r)))) (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 0) (raise/strerror 'system rv) rv)))) (define stat (lambda (path follow who) (unless (string? path) (die who "not a string" path)) (let ([r (foreign-call "ikrt_stat" (string->utf8 path) follow)]) (case r [(0) 'unknown] [(1) 'regular] [(2) 'directory] [(3) 'symlink] [(-45) #f] ;; from ikarus-errno.c: ENOENT -- path does not exist [else (raise/strerror who r path)])))) (define file-exists? (case-lambda [(path) (file-exists? path #t)] [(path follow) (and (stat path follow 'file-exists?) #t)])) (define file-regular? (case-lambda [(path) (file-regular? path #t)] [(path follow) (eq? 'regular (stat path follow 'file-regular?))])) (define file-directory? (case-lambda [(path) (file-directory? path #t)] [(path follow) (eq? 'directory (stat path follow 'file-directory?))])) (define file-symbolic-link? (lambda (path) (eq? 'symlink (stat path #f 'file-symbolic-link?)))) (define delete-file (lambda (x) (define who 'delete-file) (unless (string? x) (die who "filename is not a string" x)) (let ([v (foreign-call "ikrt_delete_file" (string->utf8 x))]) (unless (eq? v #t) (raise/strerror who v x))))) (define directory-list (lambda (path) (define who 'directory-list) (unless (string? path) (die who "not a string" path)) (let ([r (foreign-call "ikrt_directory_list" (string->utf8 path))]) (if (fixnum? r) (raise/strerror who r path) (map utf8->string (reverse r)))))) (define make-directory (case-lambda [(path) (make-directory path #o755)] [(path mode) (define who 'make-directory) (unless (string? path) (die who "not a string" path)) (unless (fixnum? mode) (die who "not a fixnum" mode)) (let ([r (foreign-call "ikrt_mkdir" (string->utf8 path) mode)]) (unless (eq? r #t) (raise/strerror who r path)))])) (define delete-directory (case-lambda [(path) (delete-directory path #f)] [(path want-error?) (define who 'delete-directory) (unless (string? path) (die who "not a string" path)) (let ([r (foreign-call "ikrt_rmdir" (string->utf8 path))]) (if want-error? (unless (eq? r #t) (raise/strerror who r path)) (eq? r #t)))])) (define change-mode (lambda (path mode) (define who 'change-mode) (unless (string? path) (die who "not a string" path)) (unless (fixnum? mode) (die who "not a fixnum" mode)) (let ([r (foreign-call "ikrt_chmod" (string->utf8 path) mode)]) (unless (eq? r #t) (raise/strerror who r path))))) (define make-symbolic-link (lambda (to path) (define who 'make-symbolic-link) (unless (and (string? to) (string? path)) (die who "not a string" (if (string? to) path to))) (let ([r (foreign-call "ikrt_symlink" (string->utf8 to) (string->utf8 path))]) (unless (eq? r #t) (raise/strerror who r path))))) (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/strerror who v 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) (raise/strerror 'current-directory v)))] [(x) (if (string? x) (let ([rv (foreign-call "ikrt_chdir" (string->utf8 x))]) (unless (eq? rv #t) (raise/strerror 'current-directory rv x))) (die 'current-directory "not a string" x))])) (define raise/strerror (case-lambda [(who errno-code) (raise/strerror who errno-code #f)] [(who errno-code filename) (raise (condition (make-who-condition who) (make-message-condition (strerror errno-code)) (if filename (make-i/o-filename-error filename) (condition))))])) (define strerror (lambda (errno-code) (define who 'strerror) (unless (fixnum? errno-code) (die who "not a fixnum" errno-code)) (let ([emsg (foreign-call "ikrt_strerror" errno-code)]) (if emsg (let ([errno-name (foreign-call "ikrt_errno_code_to_name" errno-code)]) (assert errno-name) (format "~a: ~a" (utf8->string errno-name) (utf8->string emsg))) (format "Ikarus's ~a: don't know Ikarus errno code ~s" who errno-code))))) )