Changes from Derick Eddington supporting file system info:
- Added file-regular?, file-directory?, file-symbolic-link?, directory-list, make-directory, delete-directory, change-mode, and make-symbolic-link. - Bug fix in ikrt_open_input_fd and ikrt_open_output_fd which considered a 0 FD as an error. - Bug fix in ikrt_getcwd about len+1. - Bug fix of &i/o-file-protection which didn't have &i/o-filename as its parent. - There is a new src/ikarus-errno.c file. - Made tcp-connect and friends tell when they "failed to resolve host name or connect". - To support the uses of &i/o-filename subtypes, I modified print-condition so it will cleanly print the parents' fields of a condition;
This commit is contained in:
Abdulaziz Ghuloum
parent
6437aa98e0
commit
53905b9eea
Binary file not shown.
|
|
@ -311,7 +311,7 @@
|
|||
make-i/o-filename-error i/o-filename-error?
|
||||
(filename i/o-error-filename))
|
||||
|
||||
(define-condition-type &i/o-file-protection &i/o
|
||||
(define-condition-type &i/o-file-protection &i/o-filename
|
||||
make-i/o-file-protection-error i/o-file-protection-error?)
|
||||
|
||||
(define-condition-type &i/o-file-is-read-only &i/o-file-protection
|
||||
|
|
@ -351,28 +351,38 @@
|
|||
(define print-condition
|
||||
(let ()
|
||||
(define (print-simple-condition x p)
|
||||
(let f ([rtd (record-rtd x)])
|
||||
(let* ([rtd (record-rtd x)]
|
||||
[rf (let l ([rtd rtd] [accum '()])
|
||||
(if rtd
|
||||
(l (record-type-parent rtd)
|
||||
(cons
|
||||
(cons rtd (record-type-field-names rtd))
|
||||
accum))
|
||||
(remp (lambda (a) (zero? (vector-length (cdr a))))
|
||||
accum)))]
|
||||
[rf-len (apply + (map vector-length
|
||||
(map cdr rf)))])
|
||||
(let ([name (record-type-name rtd)])
|
||||
(display name p))
|
||||
(let ([v (record-type-field-names rtd)])
|
||||
(case (vector-length v)
|
||||
[(0) (newline p)]
|
||||
[(1)
|
||||
(display ": " p)
|
||||
(write ((record-accessor rtd 0) x) p)
|
||||
(newline p)]
|
||||
[else
|
||||
(display ":\n" p)
|
||||
(let f ([i 0])
|
||||
(unless (= i (vector-length v))
|
||||
(display " " p)
|
||||
(display (vector-ref v i) p)
|
||||
(display ": " p)
|
||||
(write ((record-accessor rtd i) x) p)
|
||||
(newline)
|
||||
(f (+ i 1))))]))))
|
||||
;; (let ([parent (record-type-parent rtd)])
|
||||
;; (when parent (f parent)))))
|
||||
(display name p))
|
||||
(case rf-len
|
||||
[(0) (newline p)]
|
||||
[(1)
|
||||
(display ": " p)
|
||||
(write ((record-accessor (caar rf) 0) x) p)
|
||||
(newline p)]
|
||||
[else
|
||||
(display ":\n" p)
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(let f ([i 0] [rtd (car a)] [v (cdr a)])
|
||||
(unless (= i (vector-length v))
|
||||
(display " " p)
|
||||
(display (vector-ref v i) p)
|
||||
(display ": " p)
|
||||
(write ((record-accessor rtd i) x) p)
|
||||
(newline)
|
||||
(f (+ i 1) rtd v))))
|
||||
rf)])))
|
||||
(define (print-condition x p)
|
||||
(cond
|
||||
[(condition? x)
|
||||
|
|
|
|||
|
|
@ -76,7 +76,6 @@
|
|||
|
||||
(import
|
||||
(ikarus system $io)
|
||||
|
||||
(except (ikarus)
|
||||
port? input-port? output-port? textual-port? binary-port?
|
||||
open-file-input-port open-input-file
|
||||
|
|
@ -1187,54 +1186,26 @@
|
|||
(eof-object? (lookahead-u8 p)))]
|
||||
[else (die 'port-eof? "not an input port" p)])))
|
||||
|
||||
(define EAGAIN-error-code -22) ;;; from ikarus-io.c
|
||||
(define io-errors-vec
|
||||
'#(#| 0 |# "unknown error"
|
||||
#| 1 |# "bad file name"
|
||||
#| 2 |# "operation interrupted"
|
||||
#| 3 |# "not a directory"
|
||||
#| 4 |# "file name too long"
|
||||
#| 5 |# "missing entities"
|
||||
#| 6 |# "insufficient access privileges"
|
||||
#| 7 |# "circular path"
|
||||
#| 8 |# "file is a directory"
|
||||
#| 9 |# "file system is read-only"
|
||||
#| 10 |# "maximum open files reached"
|
||||
#| 11 |# "maximum open files reached"
|
||||
#| 12 |# "ENXIO"
|
||||
#| 13 |# "operation not supported"
|
||||
#| 14 |# "not enough space on device"
|
||||
#| 15 |# "quota exceeded"
|
||||
#| 16 |# "io error"
|
||||
#| 17 |# "device is busy"
|
||||
#| 18 |# "access fault"
|
||||
#| 19 |# "file already exists"
|
||||
#| 20 |# "invalid file name"
|
||||
#| 21 |# "non-blocking operation would block"
|
||||
#| 22 |# "broken pipe (e.g., writing to a closed process or socket)"
|
||||
#| 23 |# "connection refused"
|
||||
#| 24 |# "not a socket"
|
||||
#| 25 |# "not enough memory to perform operation"
|
||||
))
|
||||
(define EAGAIN-error-code -6) ;;; from ikarus-errno.c
|
||||
|
||||
(define (io-error who id err . other-conditions)
|
||||
(let ([err (fxnot err)])
|
||||
(let ([msg
|
||||
(cond
|
||||
[(fx< err (vector-length io-errors-vec))
|
||||
(vector-ref io-errors-vec err)]
|
||||
[else "unknown error"])])
|
||||
(raise
|
||||
(apply condition
|
||||
(make-who-condition who)
|
||||
(make-i/o-error)
|
||||
(case err
|
||||
[(6 9 18) (make-i/o-file-protection-error)]
|
||||
[(19) (make-i/o-file-already-exists-error id)]
|
||||
[else (condition)])
|
||||
(make-message-condition msg)
|
||||
(make-i/o-filename-error id)
|
||||
other-conditions)))))
|
||||
(raise
|
||||
(apply condition
|
||||
(make-who-condition who)
|
||||
(make-message-condition (strerror err))
|
||||
(case err
|
||||
;; from ikarus-errno.c: EACCES=-2, EFAULT=-21, EROFS=-71, EEXIST=-20,
|
||||
;; EIO=-29, ENOENT=-45
|
||||
;; Why is EFAULT included here?
|
||||
[(-2 -21) (make-i/o-file-protection-error id)]
|
||||
[(-71) (make-i/o-file-is-read-only-error id)]
|
||||
[(-20) (make-i/o-file-already-exists-error id)]
|
||||
[(-29) (make-i/o-error)]
|
||||
[(-45) (make-i/o-file-does-not-exist-error id)]
|
||||
[else (if id
|
||||
(make-irritants-condition (list id))
|
||||
(condition))])
|
||||
other-conditions)))
|
||||
|
||||
;(define block-size 4096)
|
||||
;(define block-size (* 4 4096))
|
||||
|
|
@ -2177,8 +2148,9 @@
|
|||
(unless (and (string? host) (string? srvc))
|
||||
(die 'who "host and service must both be strings" host srvc))
|
||||
(socket->ports
|
||||
(foreign-call foreign-name
|
||||
(string->utf8 host) (string->utf8 srvc))
|
||||
(or (foreign-call foreign-name
|
||||
(string->utf8 host) (string->utf8 srvc))
|
||||
(die 'who "failed to resolve host name or connect" host srvc))
|
||||
'who
|
||||
(string-append host ":" srvc)
|
||||
block?))]))
|
||||
|
|
@ -2252,8 +2224,8 @@
|
|||
pending)
|
||||
;;; do select
|
||||
(let ([rv (foreign-call "ikrt_select" n rbv wbv xbv)])
|
||||
(when (< rv 0)
|
||||
(die 'select "error selecting from fds")))
|
||||
(when (< rv 0)
|
||||
(io-error 'select #f rv)))
|
||||
;;; go through fds again and see if they're selected
|
||||
(for-each
|
||||
(lambda (t)
|
||||
|
|
|
|||
|
|
@ -14,15 +14,21 @@
|
|||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(library (ikarus posix)
|
||||
(library (ikarus.posix)
|
||||
(export posix-fork fork waitpid system file-exists? delete-file
|
||||
nanosleep getenv env environ file-ctime current-directory)
|
||||
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))
|
||||
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 ()
|
||||
|
|
@ -33,15 +39,17 @@
|
|||
(let ([pid (posix-fork)])
|
||||
(cond
|
||||
[(fx= pid 0) (child-proc)]
|
||||
[(fx= pid -1)
|
||||
(die 'fork "failed")]
|
||||
[(fx< pid 0) (raise/strerror 'fork pid)]
|
||||
[else (parent-proc pid)]))))
|
||||
|
||||
(define waitpid
|
||||
(lambda (pid)
|
||||
(unless (fixnum? pid)
|
||||
(die 'waitpid "not a fixnum" pid))
|
||||
(foreign-call "ikrt_waitpid" pid)))
|
||||
(let ([r (foreign-call "ikrt_waitpid" pid)])
|
||||
(if (fx< r 0)
|
||||
(raise/strerror 'waitpid r)
|
||||
r))))
|
||||
|
||||
(define system
|
||||
(lambda (x)
|
||||
|
|
@ -49,59 +57,110 @@
|
|||
(die 'system "not a string" x))
|
||||
(let ([rv (foreign-call "ik_system"
|
||||
(string->utf8 x))])
|
||||
(if (fx= rv -1)
|
||||
(die 'system "failed")
|
||||
(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?
|
||||
(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)))]))))
|
||||
(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 'delete-file "filename is not a string" x))
|
||||
(die who "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)))]))))
|
||||
(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)
|
||||
|
|
@ -111,12 +170,7 @@
|
|||
(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)))]))))
|
||||
[else (raise/strerror who v x)]))))
|
||||
|
||||
|
||||
(define ($getenv-bv key)
|
||||
|
|
@ -189,17 +243,43 @@
|
|||
(case-lambda
|
||||
[()
|
||||
(let ([v (foreign-call "ikrt_getcwd")])
|
||||
(if (bytevector? v)
|
||||
(utf8->string v)
|
||||
(die 'current-directory
|
||||
"failed to get current directory")))]
|
||||
(if (eq? v #t)
|
||||
(raise/strerror 'current-directory v)
|
||||
(utf8->string v)))]
|
||||
[(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")))
|
||||
(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)))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1491
|
||||
1492
|
||||
|
|
|
|||
|
|
@ -70,6 +70,7 @@
|
|||
"ikarus.command-line.ss"
|
||||
"ikarus.codecs.ss"
|
||||
"ikarus.bytevectors.ss"
|
||||
"ikarus.posix.ss"
|
||||
"ikarus.io.ss"
|
||||
"ikarus.hash-tables.ss"
|
||||
"ikarus.pretty-formats.ss"
|
||||
|
|
@ -94,7 +95,6 @@
|
|||
"ikarus.load.ss"
|
||||
"ikarus.pretty-print.ss"
|
||||
"ikarus.cafe.ss"
|
||||
"ikarus.posix.ss"
|
||||
"ikarus.timer.ss"
|
||||
"ikarus.time-and-date.ss"
|
||||
"ikarus.sort.ss"
|
||||
|
|
@ -361,6 +361,7 @@
|
|||
[make-parameter i parameters]
|
||||
[call/cf i]
|
||||
[print-error i]
|
||||
[strerror i]
|
||||
[interrupt-handler i]
|
||||
[engine-handler i]
|
||||
[assembler-output i]
|
||||
|
|
@ -1215,7 +1216,15 @@
|
|||
[vector-sort! i r sr]
|
||||
[file-exists? i r fi]
|
||||
[delete-file i r fi]
|
||||
[file-regular? i]
|
||||
[file-directory? i]
|
||||
[file-symbolic-link? i]
|
||||
[current-directory i]
|
||||
[directory-list i]
|
||||
[make-directory i]
|
||||
[delete-directory i]
|
||||
[change-mode i]
|
||||
[make-symbolic-link i]
|
||||
[file-ctime i]
|
||||
[define-record-type i r rs]
|
||||
[fields i r rs]
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
|
|||
ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c \
|
||||
ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
|
||||
ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
|
||||
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c
|
||||
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
|
||||
ikarus-errno.c
|
||||
|
||||
scheme_script_SOURCES = scheme-script.c
|
||||
|
||||
|
|
|
|||
|
|
@ -54,7 +54,8 @@ am_ikarus_OBJECTS = ikarus-collect.$(OBJEXT) ikarus-exec.$(OBJEXT) \
|
|||
ikarus-verify-integrity.$(OBJEXT) ikarus-weak-pairs.$(OBJEXT) \
|
||||
ikarus-winmmap.$(OBJEXT) ikarus-enter.$(OBJEXT) \
|
||||
cpu_has_sse2.$(OBJEXT) ikarus-io.$(OBJEXT) \
|
||||
ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT)
|
||||
ikarus-process.$(OBJEXT) ikarus-getaddrinfo.$(OBJEXT) \
|
||||
ikarus-errno.$(OBJEXT)
|
||||
nodist_ikarus_OBJECTS =
|
||||
ikarus_OBJECTS = $(am_ikarus_OBJECTS) $(nodist_ikarus_OBJECTS)
|
||||
ikarus_LDADD = $(LDADD)
|
||||
|
|
@ -181,7 +182,8 @@ ikarus_SOURCES = ikarus-collect.c ikarus-exec.c ikarus-fasl.c \
|
|||
ikarus-runtime.c ikarus-symbol-table.c ikarus-verify-integrity.c \
|
||||
ikarus-weak-pairs.c ikarus-winmmap.c ikarus-data.h \
|
||||
ikarus-winmmap.h ikarus-enter.S cpu_has_sse2.S ikarus-io.c \
|
||||
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c
|
||||
ikarus-process.c ikarus-getaddrinfo.h ikarus-getaddrinfo.c \
|
||||
ikarus-errno.c
|
||||
|
||||
scheme_script_SOURCES = scheme-script.c
|
||||
nodist_ikarus_SOURCES = bootfileloc.h
|
||||
|
|
@ -260,6 +262,7 @@ distclean-compile:
|
|||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/cpu_has_sse2.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-collect.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-enter.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-errno.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-exec.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-fasl.Po@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ikarus-flonums.Po@am__quote@
|
||||
|
|
|
|||
|
|
@ -29,48 +29,13 @@
|
|||
#include <netinet/in.h>
|
||||
#include "ikarus-data.h"
|
||||
|
||||
ikptr
|
||||
ikrt_io_error(){
|
||||
int err = errno;
|
||||
#if 0
|
||||
fprintf(stderr, "errno=%d %s\n", err, strerror(err));
|
||||
#endif
|
||||
switch(err){
|
||||
case EBADF : return fix(-2);
|
||||
case EINTR : return fix(-3);
|
||||
case ENOTDIR : return fix(-4);
|
||||
case ENAMETOOLONG : return fix(-5);
|
||||
case ENOENT : return fix(-6);
|
||||
case EACCES : return fix(-7);
|
||||
case ELOOP : return fix(-8);
|
||||
case EISDIR : return fix(-9);
|
||||
case EROFS : return fix(-10);
|
||||
case EMFILE : return fix(-11);
|
||||
case ENFILE : return fix(-12);
|
||||
case ENXIO : return fix(-13);
|
||||
case EOPNOTSUPP : return fix(-14);
|
||||
case ENOSPC : return fix(-15);
|
||||
case EDQUOT : return fix(-16);
|
||||
case EIO : return fix(-17);
|
||||
case ETXTBSY : return fix(-18);
|
||||
case EFAULT : return fix(-19);
|
||||
case EEXIST : return fix(-20);
|
||||
case EINVAL : return fix(-21);
|
||||
case EAGAIN : return fix(-22); /* hardcoded in ikarus.io.ss */
|
||||
case EPIPE : return fix(-23);
|
||||
case ECONNREFUSED : return fix(-24);
|
||||
case ENOTSOCK : return fix(-25);
|
||||
case ENOBUFS : return fix(-26);
|
||||
}
|
||||
return fix(-1);
|
||||
}
|
||||
|
||||
extern ikptr ik_errno_to_code();
|
||||
|
||||
ikptr
|
||||
ikrt_close_fd(ikptr fd, ikpcb* pcb){
|
||||
int err = close(unfix(fd));
|
||||
if(err == -1){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
} else {
|
||||
return false_object;;
|
||||
}
|
||||
|
|
@ -79,10 +44,10 @@ ikrt_close_fd(ikptr fd, ikpcb* pcb){
|
|||
ikptr
|
||||
ikrt_open_input_fd(ikptr fn, ikpcb* pcb){
|
||||
int fh = open((char*)(long)(fn+off_bytevector_data), O_RDONLY, 0);
|
||||
if(fh > 0){
|
||||
if(fh >= 0){
|
||||
return fix(fh);
|
||||
} else {
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -107,10 +72,10 @@ ikrt_open_output_fd(ikptr fn, ikptr ikopts, ikpcb* pcb){
|
|||
int fh = open((char*)(long)(fn+off_bytevector_data),
|
||||
mode,
|
||||
S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH);
|
||||
if(fh > 0){
|
||||
if(fh >= 0){
|
||||
return fix(fh);
|
||||
} else {
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -130,7 +95,7 @@ ikrt_read_fd(ikptr fd, ikptr bv, ikptr off, ikptr cnt, ikpcb* pcb){
|
|||
if(bytes >= 0){
|
||||
return fix(bytes);
|
||||
} else {
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -159,7 +124,7 @@ ikrt_write_fd(ikptr fd, ikptr bv, ikptr off, ikptr cnt, ikpcb* pcb){
|
|||
if(bytes >= 0){
|
||||
return fix(bytes);
|
||||
} else {
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -173,22 +138,25 @@ do_connect(ikptr host, ikptr srvc, int socket_type){
|
|||
0,
|
||||
&info);
|
||||
if(err){
|
||||
return fix(-1);
|
||||
switch(err){
|
||||
case EAI_SYSTEM: return ik_errno_to_code();
|
||||
default: return false_object;
|
||||
}
|
||||
}
|
||||
struct addrinfo* i = info;
|
||||
ikptr sock = fix(-1);
|
||||
ikptr sock = false_object;
|
||||
while(i){
|
||||
if(i->ai_socktype != socket_type){
|
||||
i = i->ai_next;
|
||||
} else {
|
||||
int s = socket(i->ai_family, i->ai_socktype, i->ai_protocol);
|
||||
if(s < 0){
|
||||
sock = ikrt_io_error();
|
||||
sock = ik_errno_to_code();
|
||||
i = i->ai_next;
|
||||
} else {
|
||||
int err = connect(s, i->ai_addr, i->ai_addrlen);
|
||||
if(err < 0){
|
||||
sock = ikrt_io_error();
|
||||
sock = ik_errno_to_code();
|
||||
i = i->ai_next;
|
||||
} else {
|
||||
sock = fix(s);
|
||||
|
|
@ -216,7 +184,7 @@ ikrt_make_fd_nonblocking(ikptr fdptr, ikpcb* pcb){
|
|||
int fd = unfix(fdptr);
|
||||
int err = fcntl(fd, F_SETFL, O_NONBLOCK);
|
||||
if(err == -1){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -229,7 +197,7 @@ ikrt_select(ikptr fds, ikptr rfds, ikptr wfds, ikptr xfds, ikpcb* pcb){
|
|||
(fd_set*)(xfds + off_bytevector_data),
|
||||
NULL);
|
||||
if(rv < 0){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
return fix(rv);
|
||||
}
|
||||
|
|
@ -239,7 +207,7 @@ ikrt_listen(ikptr port, ikpcb* pcb){
|
|||
|
||||
int sock = socket(AF_INET, SOCK_STREAM, 0);
|
||||
if(sock < 0){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
struct sockaddr_in servaddr;
|
||||
|
|
@ -253,18 +221,18 @@ ikrt_listen(ikptr port, ikpcb* pcb){
|
|||
int reuse = 1;
|
||||
err = setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, &reuse, sizeof(int));
|
||||
if(err < 0){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
|
||||
err = bind(sock, (struct sockaddr *)&servaddr, sizeof(servaddr));
|
||||
if(err < 0){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
err = listen(sock, 1024);
|
||||
if(err < 0){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
return fix(sock);
|
||||
}
|
||||
|
|
@ -283,7 +251,7 @@ ikrt_getsockname(ikptr s, ikpcb* pcb){
|
|||
ref(bv, off_bytevector_length) = fix(size);
|
||||
return bv;
|
||||
} else {
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
|
@ -297,7 +265,7 @@ ikrt_accept(ikptr s, ikptr bv, ikpcb* pcb){
|
|||
(struct sockaddr*) (bv+off_bytevector_data),
|
||||
&addrlen);
|
||||
if(sock < 0){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
ref(bv, off_bytevector_length) = fix(addrlen);
|
||||
return fix(sock);
|
||||
|
|
@ -311,7 +279,7 @@ ikrt_shutdown(ikptr s, ikpcb* pcb){
|
|||
int err = shutdown(unfix(s), SHUT_RDWR);
|
||||
#endif
|
||||
if(err < 0){
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -322,7 +290,7 @@ ikrt_file_ctime(ikptr filename, ikptr res){
|
|||
struct stat s;
|
||||
int err = stat((char*)(filename + off_bytevector_data), &s);
|
||||
if(err) {
|
||||
return fix(errno);
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
ref(res, off_car) = fix(s.st_ctime);
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
#include <errno.h>
|
||||
#include "ikarus-data.h"
|
||||
|
||||
extern ikptr ikrt_io_error();
|
||||
extern ikptr ik_errno_to_code();
|
||||
|
||||
static int
|
||||
list_length(ikptr x){
|
||||
|
|
@ -56,9 +56,9 @@ ikrt_process(ikptr rvec, ikptr cmd, ikptr argv, ikpcb* pcb){
|
|||
int infds[2];
|
||||
int outfds[2];
|
||||
int errfds[2];
|
||||
if(pipe(infds)) return ikrt_io_error();
|
||||
if(pipe(outfds)) return ikrt_io_error();
|
||||
if(pipe(errfds)) return ikrt_io_error();
|
||||
if(pipe(infds)) return ik_errno_to_code();
|
||||
if(pipe(outfds)) return ik_errno_to_code();
|
||||
if(pipe(errfds)) return ik_errno_to_code();
|
||||
pid_t pid = fork();
|
||||
if(pid == 0){
|
||||
/* child */
|
||||
|
|
@ -87,13 +87,18 @@ ikrt_process(ikptr rvec, ikptr cmd, ikptr argv, ikpcb* pcb){
|
|||
ref(rvec,off_vector_data+3*wordsize) = fix(errfds[0]);
|
||||
return rvec;
|
||||
} else {
|
||||
return ikrt_io_error();
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_waitpid(ikptr pid, ikpcb* pcb){
|
||||
int status;
|
||||
waitpid(unfix(pid), &status, 0);
|
||||
return fix(status);
|
||||
pid_t r = waitpid(unfix(pid), &status, 0);
|
||||
if(r >= 0){
|
||||
return fix(status);
|
||||
} else {
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -33,11 +33,14 @@
|
|||
#include <sys/resource.h>
|
||||
#include <sys/wait.h>
|
||||
#include <sys/param.h>
|
||||
#include <dirent.h>
|
||||
#ifdef __CYGWIN__
|
||||
#include "ikarus-winmmap.h"
|
||||
#endif
|
||||
|
||||
|
||||
extern ikptr ik_errno_to_code();
|
||||
|
||||
int total_allocated_pages = 0;
|
||||
|
||||
extern char **environ;
|
||||
|
|
@ -553,97 +556,48 @@ ikptr ik_uuid(ikptr bv){
|
|||
}
|
||||
|
||||
|
||||
|
||||
/*
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
int
|
||||
stat(const char *path, struct stat *sb);
|
||||
ERRORS
|
||||
Stat() and lstat() will fail if:
|
||||
[ENOTDIR] A component of the path prefix is not a directory.
|
||||
[ENAMETOOLONG] A component of a pathname exceeded {NAME_MAX} charac-
|
||||
ters, or an entire path name exceeded {PATH_MAX} char-
|
||||
acters.
|
||||
[ENOENT] The named file does not exist.
|
||||
[EACCES] Search permission is denied for a component of the
|
||||
path prefix.
|
||||
[ELOOP] Too many symbolic links were encountered in translat-
|
||||
ing the pathname.
|
||||
[EFAULT] Sb or name points to an invalid address.
|
||||
[EIO] An I/O error occurred while reading from or writing to
|
||||
the file system.
|
||||
*/
|
||||
ikptr
|
||||
ikrt_file_exists(ikptr filename){
|
||||
char* str;
|
||||
if(tagof(filename) == bytevector_tag){
|
||||
str = (char*)(long)(filename + off_bytevector_data);
|
||||
} else {
|
||||
fprintf(stderr, "bug in ikrt_file_exists\n");
|
||||
exit(-1);
|
||||
ikptr
|
||||
ikrt_stat(ikptr filename, ikptr follow, ikpcb* pcb){
|
||||
char* fn = (char*)(filename + off_bytevector_data);
|
||||
struct stat s;
|
||||
int r;
|
||||
if(follow == false_object){
|
||||
r = lstat(fn, &s);
|
||||
} else{
|
||||
r = stat(fn, &s);
|
||||
}
|
||||
struct stat sb;
|
||||
int st = stat(str, &sb);
|
||||
if(st == 0){
|
||||
/* success */
|
||||
return true_object;
|
||||
} else {
|
||||
int err = errno;
|
||||
if(err == ENOENT){
|
||||
return false_object;
|
||||
}
|
||||
else if(err == ENOTDIR){
|
||||
if(r == 0){
|
||||
if(S_ISREG(s.st_mode)){
|
||||
return fix(1);
|
||||
}
|
||||
else if(err == ENAMETOOLONG){
|
||||
else if(S_ISDIR(s.st_mode)){
|
||||
return fix(2);
|
||||
}
|
||||
else if(err == EACCES){
|
||||
return fix(3);
|
||||
}
|
||||
else if(err == ELOOP){
|
||||
return fix(4);
|
||||
}
|
||||
else if(err == EFAULT){
|
||||
return fix(5);
|
||||
}
|
||||
else if(err == EIO){
|
||||
return fix(6);
|
||||
}
|
||||
else {
|
||||
return fix(-1);
|
||||
}
|
||||
}
|
||||
else if(S_ISLNK(s.st_mode)){
|
||||
return fix(3);
|
||||
}
|
||||
else {
|
||||
return fix(0);
|
||||
}
|
||||
}
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
[ENOTDIR] A component of the path prefix is not a directory.
|
||||
[ENAMETOOLONG] A component of a pathname exceeded {NAME_MAX} charac-
|
||||
ters, or an entire path name exceeded {PATH_MAX} char-
|
||||
acters.
|
||||
[ENOENT] The named file does not exist.
|
||||
[EACCES] Search permission is denied for a component of the
|
||||
path prefix.
|
||||
[EACCES] Write permission is denied on the directory containing
|
||||
the link to be removed.
|
||||
[ELOOP] Too many symbolic links were encountered in translat-
|
||||
ing the pathname.
|
||||
[EPERM] The named file is a directory and the effective user
|
||||
ID of the process is not the super-user.
|
||||
[EPERM] The directory containing the file is marked sticky,
|
||||
and neither the containing directory nor the file to
|
||||
be removed are owned by the effective user ID.
|
||||
[EBUSY] The entry to be unlinked is the mount point for a
|
||||
mounted file system.
|
||||
[EIO] An I/O error occurred while deleting the directory
|
||||
entry or deallocating the inode.
|
||||
[EROFS] The named file resides on a read-only file system.
|
||||
[EFAULT] Path points outside the process's allocated address
|
||||
space.
|
||||
*/
|
||||
|
||||
/* ikrt_file_exists needs to be removed.
|
||||
This is here only to be able to use old ikarus.boot.prebuilt */
|
||||
ikptr
|
||||
ikrt_file_exists(ikptr filename, ikpcb* pcb){
|
||||
switch (ikrt_stat(filename, true_object, pcb)){
|
||||
case fix(0):
|
||||
case fix(1):
|
||||
case fix(2):
|
||||
case fix(3):
|
||||
return true_object;
|
||||
default:
|
||||
return false_object;
|
||||
}
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_delete_file(ikptr filename){
|
||||
|
|
@ -656,30 +610,89 @@ ikrt_delete_file(ikptr filename){
|
|||
}
|
||||
int err = unlink(str);
|
||||
if(err == 0){
|
||||
return 0;
|
||||
return true_object;
|
||||
}
|
||||
switch (errno){
|
||||
case ENOTDIR: return fix(1);
|
||||
case ENAMETOOLONG: return fix(2);
|
||||
case ENOENT: return fix(3);
|
||||
case EACCES: return fix(4);
|
||||
case ELOOP: return fix(5);
|
||||
case EPERM: return fix(6);
|
||||
case EBUSY: return fix(7);
|
||||
case EIO: return fix(8);
|
||||
case EROFS: return fix(9);
|
||||
case EFAULT: return fix(10);
|
||||
}
|
||||
return fix(-1);
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_directory_list(ikptr filename, ikpcb* pcb){
|
||||
DIR* dir;
|
||||
struct dirent* de;
|
||||
if((dir = opendir((char*)(filename + off_bytevector_data))) == NULL){
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
ikptr ac = null_object;
|
||||
pcb->root0 = ∾
|
||||
while(1){
|
||||
errno = 0;
|
||||
de = readdir(dir);
|
||||
if(de == NULL){
|
||||
pcb->root0 = 0;
|
||||
pcb->root1 = 0;
|
||||
ikptr retval = (errno ? ik_errno_to_code() : ac);
|
||||
closedir(dir);
|
||||
return retval;
|
||||
}
|
||||
int len = strlen(de->d_name);
|
||||
ikptr bv = ik_safe_alloc(pcb, align(disp_bytevector_data+len+1))
|
||||
+ bytevector_tag;
|
||||
ref(bv, off_bytevector_length) = fix(len);
|
||||
memcpy((char*)(bv+off_bytevector_data), de->d_name, len+1);
|
||||
pcb->root1 = &bv;
|
||||
ikptr p = ik_safe_alloc(pcb, pair_size) + pair_tag;
|
||||
ref(p, off_car) = bv;
|
||||
ref(p, off_cdr) = ac;
|
||||
ac = p;
|
||||
}
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_mkdir(ikptr path, ikptr mode, ikpcb* pcb){
|
||||
int r = mkdir((char*)(path+off_bytevector_data), unfix(mode));
|
||||
if(r == 0){
|
||||
return true_object;
|
||||
}
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_rmdir(ikptr path, ikpcb* pcb){
|
||||
int r = rmdir((char*)(path+off_bytevector_data));
|
||||
if(r == 0){
|
||||
return true_object;
|
||||
}
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_chmod(ikptr path, ikptr mode, ikpcb* pcb){
|
||||
int r = chmod((char*)(path+off_bytevector_data), (mode_t)unfix(mode));
|
||||
if(r == 0){
|
||||
return true_object;
|
||||
}
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_symlink(ikptr to, ikptr path, ikpcb* pcb){
|
||||
int r = symlink((char*)(to+off_bytevector_data), (char*)(path+off_bytevector_data));
|
||||
if(r == 0){
|
||||
return true_object;
|
||||
}
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
|
||||
ikptr
|
||||
ik_system(ikptr str){
|
||||
if(tagof(str) == bytevector_tag){
|
||||
return fix(system((char*)(long)(str+off_bytevector_data)));
|
||||
int r = system((char*)(long)(str+off_bytevector_data));
|
||||
if(r >= 0) {
|
||||
return fix(r);
|
||||
} else {
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
} else {
|
||||
fprintf(stderr, "bug in ik_system\n");
|
||||
exit(-1);
|
||||
|
|
@ -817,9 +830,6 @@ ikrt_register_guardian(ikptr tc, ikptr obj, ikpcb* pcb){
|
|||
return ikrt_register_guardian_pair(p0, pcb);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
ikptr
|
||||
ikrt_stats_now(ikptr t, ikpcb* pcb){
|
||||
struct rusage r;
|
||||
|
|
@ -881,7 +891,11 @@ ikrt_gmt_offset(ikptr t){
|
|||
ikptr
|
||||
ikrt_fork(){
|
||||
int pid = fork();
|
||||
return fix(pid);
|
||||
if(pid >= 0){
|
||||
return fix(pid);
|
||||
} else {
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -898,6 +912,7 @@ ikrt_getenv(ikptr bv, ikpcb* pcb){
|
|||
return s;
|
||||
}
|
||||
else {
|
||||
/* empty bv */
|
||||
ikptr s = ik_safe_alloc(pcb, align(disp_bytevector_data+1))
|
||||
+ bytevector_tag;
|
||||
ref(s, -bytevector_tag) = fix(0);
|
||||
|
|
@ -995,7 +1010,10 @@ ikrt_nanosleep(ikptr secs, ikptr nsecs, ikpcb* pcb){
|
|||
ikptr
|
||||
ikrt_chdir(ikptr pathbv, ikpcb* pcb){
|
||||
int err = chdir(off_bytevector_data+(char*)pathbv);
|
||||
return fix(err); /* FIXME: provide more meaninful result */
|
||||
if(err == 0){
|
||||
return true_object;
|
||||
}
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
|
||||
ikptr
|
||||
|
|
@ -1003,12 +1021,12 @@ ikrt_getcwd(ikpcb* pcb){
|
|||
char buff[MAXPATHLEN+1];
|
||||
char* path = getcwd(buff, MAXPATHLEN);
|
||||
if(! path){
|
||||
return fix(-1); /* FIXME: provide more meaninful result */
|
||||
return ik_errno_to_code();
|
||||
}
|
||||
int len = strlen(path);
|
||||
ikptr bv = ik_safe_alloc(pcb, align(disp_bytevector_data+len+1));
|
||||
ref(bv,0) = fix(len);
|
||||
strncpy(disp_bytevector_data+(char*)(bv), path, len);
|
||||
memcpy(disp_bytevector_data+(char*)(bv), path, len+1);
|
||||
return bv+bytevector_tag;
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue