Compare commits

...

2 Commits

6 changed files with 117 additions and 116 deletions

1
.gitignore vendored
View File

@ -1,3 +1,4 @@
*.tgz *.tgz
venv venv
*.html *.html
*.log

View File

@ -1,6 +1,3 @@
.SILENT: build install clean test-r6rs test-r6rs-docker test-r7rs \
test-r7rs-docker
.PHONY: test-r6rs test-r7rs
SCHEME=chibi SCHEME=chibi
RNRS=r7rs RNRS=r7rs
SRFI=170 SRFI=170
@ -32,27 +29,25 @@ install:
uninstall: uninstall:
-snow-chibi remove --impls=${SCHEME} ${PKG} -snow-chibi remove --impls=${SCHEME} ${PKG}
init-venv: build run-test-venv: build
@rm -rf venv rm -rf venv
@scheme-venv ${SCHEME} ${RNRS} venv scheme-venv ${SCHEME} ${RNRS} venv
@echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (srfi ${SRFI}))" > venv/test.scm echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (foreign c) (srfi ${SRFI}))" > venv/test.scm
@printf "#!r6rs\n(import (rnrs) (srfi :64) (srfi :${SRFI}))" > venv/test.sps printf "#!r6rs\n(import (rnrs) (srfi :64) (foreign c) (srfi :${SRFI}))" > venv/test.sps
@cat ${TESTFILE} >> venv/test.scm cat ${TESTFILE} >> venv/test.scm
@cat ${TESTFILE} >> venv/test.sps cat ${TESTFILE} >> venv/test.sps
@if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign venv/lib/; fi; fi
@if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi if [ "${RNRS}" = "r6rs" ]; then cp -r retropikzel venv/lib/; fi
@if [ "${SCHEME}" = "chezs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi if [ "${SCHEME}" = "chezs" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
@if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi if [ "${SCHEME}" = "ikarus" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
@if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi if [ "${SCHEME}" = "ironscheme" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
@if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi if [ "${SCHEME}" = "racket" ]; then ./venv/bin/akku install akku-r7rs chez-srfi; fi
@if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/akku install; fi if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/akku install; fi
@if [ "${SCHEME}" = "chicken" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi if [ "${SCHEME}" = "chicken" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
@if [ "${SCHEME}-${RNRS}" = "mosh-r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi if [ "${SCHEME}-${RNRS}" = "mosh-r7rs" ]; then ./venv/bin/snow-chibi install --always-yes srfi.64; fi
@if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi if [ "${RNRS}" = "r7rs" ]; then ./venv/bin/snow-chibi install ${PKG}; fi
run-test: init-venv
if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/scheme-compile venv/test.sps; fi if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/scheme-compile venv/test.sps; fi
if [ "${RNRS}" = "r7rs" ]; then VENV_CSC_ARGS="-L -lcurl" ./venv/bin/scheme-compile venv/test.scm; fi if [ "${RNRS}" = "r7rs" ]; then CSC_OPTIONS="-L -lcurl" ./venv/bin/scheme-compile venv/test.scm; fi
./venv/test ./venv/test
test-r7rs: tmpdir test-r7rs: tmpdir

View File

@ -1,5 +1,5 @@
(define-c-library libc (define-c-library libc
`("sys/types.h" '("sys/types.h"
"sys/socket.h" "sys/socket.h"
"sys/un.h" "sys/un.h"
"netinet/in.h" "netinet/in.h"
@ -8,8 +8,8 @@
"fcntl.h" "fcntl.h"
"poll.h" "poll.h"
"string.h") "string.h")
libc-name #f
'((additional-versions ("0" "6")))) '())
(define-c-procedure c-socket libc 'socket 'int '(int int int)) (define-c-procedure c-socket libc 'socket 'int '(int int int))
(define-c-procedure c-setsockopt libc 'setsockopt 'int '(int int int pointer int)) (define-c-procedure c-setsockopt libc 'setsockopt 'int '(int int int pointer int))
@ -103,8 +103,8 @@
(call-with-address-of (call-with-address-of
addrinfo-hints addrinfo-hints
(lambda (addrinfo-hints-address) (lambda (addrinfo-hints-address)
(c-getaddrinfo (string->c-utf8 node) (c-getaddrinfo (string->c-bytevector node)
(string->c-utf8 service) (string->c-bytevector service)
addrinfo-hints addrinfo-hints
addrinfo-address)))))) addrinfo-address))))))
(socket-file-descriptor (socket-file-descriptor
@ -113,13 +113,13 @@
(c-bytevector-ref addrinfo 'int ai-socktype-offset) (c-bytevector-ref addrinfo 'int ai-socktype-offset)
(c-bytevector-ref addrinfo 'int ai-protocol-offset)))) (c-bytevector-ref addrinfo 'int ai-protocol-offset))))
(when (< addrinfo-result 0) (when (< addrinfo-result 0)
(c-perror (string->c-utf8 "make-client-socket (addrinfo) error")) (c-perror (string->c-bytevector "make-client-socket (addrinfo) error"))
(raise-continuable "make-client-socket (addrinfo) error")) (raise-continuable "make-client-socket (addrinfo) error"))
(when (< socket-file-descriptor 0) (when (< socket-file-descriptor 0)
(c-perror (string->c-utf8 "make-client-socket (socket) error")) (c-perror (string->c-bytevector "make-client-socket (socket) error"))
(raise-continuable "make-client-socket (socket) error")) (raise-continuable "make-client-socket (socket) error"))
(when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0) (when (< (c-fcntl socket-file-descriptor F-SETFL O-NONBLOCK) 0)
(c-perror (string->c-utf8 "make-client-socket (fcntl) error")) (c-perror (string->c-bytevector "make-client-socket (fcntl) error"))
(raise-continuable "make-client-socket (fcntl) error")) (raise-continuable "make-client-socket (fcntl) error"))
(letrec* ((ai-addr-offset (* (c-type-size 'int) 6)) (letrec* ((ai-addr-offset (* (c-type-size 'int) 6))
(ai-addrlen-offset (* (c-type-size 'int) 4)) (ai-addrlen-offset (* (c-type-size 'int) 4))
@ -132,7 +132,7 @@
(c-bytevector-set! pollfd 'int 0 0) (c-bytevector-set! pollfd 'int 0 0)
;; FIXME No magic numbers, like 8 or 1 here. Put into variable with good name ;; FIXME No magic numbers, like 8 or 1 here. Put into variable with good name
;; TODO Why 8 works but 1 does not? ;; TODO Why 8 works but 1 does not?
(when (= (c-poll pollfd 8 5000) 0) #;(when (= (c-poll pollfd 8 5000) 0)
(error "make-client-socket (poll) error"))) (error "make-client-socket (poll) error")))
(make-socket socket-file-descriptor)))) (make-socket socket-file-descriptor))))
@ -153,7 +153,7 @@
(msg-len (bytevector-length bv)) (msg-len (bytevector-length bv))
(sent-count (c-send (socket-file-descriptor socket) msg msg-len 0))) (sent-count (c-send (socket-file-descriptor socket) msg msg-len 0)))
(when (= sent-count -1) (when (= sent-count -1)
(c-perror (string->c-utf8 "socket-send error")) (c-perror (string->c-bytevector "socket-send error"))
(raise-continuable "socket-send error")) (raise-continuable "socket-send error"))
sent-count)) sent-count))
@ -194,26 +194,26 @@
(c-type-size 'u16) (c-type-size 'u16)
(c-htons (string->number service))) (c-htons (string->number service)))
(c-bytevector-set! pointer 'u16 (* (c-type-size 'u16) 2) INADDR-ANY) (c-bytevector-set! pointer 'u16 (* (c-type-size 'u16) 2) INADDR-ANY)
;(c-strcpy node-pointer (string->c-utf8 node)) ;(c-strcpy node-pointer (string->c-bytevector node))
pointer)) pointer))
(option (let ((pointer (make-c-bytevector (c-type-size 'int)))) (option (let ((pointer (make-c-bytevector (c-type-size 'int))))
(c-bytevector-set! pointer 'int 0 1) (c-bytevector-set! pointer 'int 0 1)
pointer)) pointer))
(sockaddr-size (+ *ai-family-size* (bytevector-length (string->utf8 node))))) (sockaddr-size (+ *ai-family-size* (bytevector-length (string->utf8 node)))))
(when (< socket-file-descriptor 0) (when (< socket-file-descriptor 0)
(c-perror (string->c-utf8 "make-server-socket (socket) error")) (c-perror (string->c-bytevector "make-server-socket (socket) error"))
(raise-continuable "make-server-socket (socket) error")) (raise-continuable "make-server-socket (socket) error"))
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0) (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0)
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error")) (c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEADDR) error"))
(raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error")) (raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error"))
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0) (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0)
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error")) (c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEPORT) error"))
(raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error")) (raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error"))
(when (< (c-bind socket-file-descriptor sockaddr *sockaddr-size*) 0) (when (< (c-bind socket-file-descriptor sockaddr *sockaddr-size*) 0)
(c-perror (string->c-utf8 "socket-accept (bind) error")) (c-perror (string->c-bytevector "socket-accept (bind) error"))
(raise-continuable "socket-accept (bind) error")) (raise-continuable "socket-accept (bind) error"))
(when (< (c-listen socket-file-descriptor 0) 0) (when (< (c-listen socket-file-descriptor 0) 0)
(c-perror (string->c-utf8 "make-server-socket (listen) error")) (c-perror (string->c-bytevector "make-server-socket (listen) error"))
(raise-continuable "make-server-socket (listen) error")) (raise-continuable "make-server-socket (listen) error"))
(make-socket socket-file-descriptor))) (make-socket socket-file-descriptor)))
@ -240,8 +240,8 @@
(call-with-address-of (call-with-address-of
addrinfo-hints addrinfo-hints
(lambda (addrinfo-hints-address) (lambda (addrinfo-hints-address)
(c-getaddrinfo (string->c-utf8 "0.0.0.0") (c-getaddrinfo (string->c-bytevector "0.0.0.0")
(string->c-utf8 service) (string->c-bytevector service)
addrinfo-hints addrinfo-hints
addrinfo-address)))))) addrinfo-address))))))
(socket-file-descriptor (socket-file-descriptor
@ -257,22 +257,22 @@
(ai-addrlen-offset (* (c-type-size 'int) 4)) (ai-addrlen-offset (* (c-type-size 'int) 4))
(ai-addr-len (c-bytevector-ref addrinfo 'int ai-addrlen-offset))) (ai-addr-len (c-bytevector-ref addrinfo 'int ai-addrlen-offset)))
(when (< addrinfo-result 0) (when (< addrinfo-result 0)
(c-perror (string->c-utf8 "make-server-socket (addrinfo) error")) (c-perror (string->c-bytevector "make-server-socket (addrinfo) error"))
(raise-continuable "make-server-socket (addrinfo) error")) (raise-continuable "make-server-socket (addrinfo) error"))
(when (< socket-file-descriptor 0) (when (< socket-file-descriptor 0)
(c-perror (string->c-utf8 "make-server-socket (socket) error")) (c-perror (string->c-bytevector "make-server-socket (socket) error"))
(raise-continuable "make-server-socket (socket) error")) (raise-continuable "make-server-socket (socket) error"))
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0) (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEADDR option (c-type-size 'int)) 0)
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEADDR) error")) (c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEADDR) error"))
(raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error")) (raise-continuable "make-server-socket (setsockopt SO-REUSEADDR) error"))
(when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0) (when (< (c-setsockopt socket-file-descriptor SOL-SOCKET SO-REUSEPORT option (c-type-size 'int)) 0)
(c-perror (string->c-utf8 "make-server-socket (setsockopt SO-REUSEPORT) error")) (c-perror (string->c-bytevector "make-server-socket (setsockopt SO-REUSEPORT) error"))
(raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error")) (raise-continuable "make-server-socket (setsockopt SO-REUSEPORT) error"))
(when (< (c-bind socket-file-descriptor ai-addr ai-addr-len) 0) (when (< (c-bind socket-file-descriptor ai-addr ai-addr-len) 0)
(c-perror (string->c-utf8 "make-server-socket (bind) error")) (c-perror (string->c-bytevector "make-server-socket (bind) error"))
(raise-continuable "make-server-socket (bind) error")) (raise-continuable "make-server-socket (bind) error"))
(when (< (c-listen socket-file-descriptor 5) 0) (when (< (c-listen socket-file-descriptor 5) 0)
(c-perror (string->c-utf8 "make-server-socket (listen) error")) (c-perror (string->c-bytevector "make-server-socket (listen) error"))
(raise-continuable "make-server-socket (listen) error")) (raise-continuable "make-server-socket (listen) error"))
(make-socket socket-file-descriptor)))) (make-socket socket-file-descriptor))))
@ -285,7 +285,7 @@
client-sockaddr client-sockaddr
addrlen))) addrlen)))
(when (< accepted-socket 0) (when (< accepted-socket 0)
(c-perror (string->c-utf8 "socket-accept (accept) error")) (c-perror (string->c-bytevector "socket-accept (accept) error"))
(raise-continuable "socket-accept (accept) error")) (raise-continuable "socket-accept (accept) error"))
(make-socket accepted-socket))) (make-socket accepted-socket)))

View File

@ -1,8 +1,9 @@
(test-begin "srfi-106")
(define sock1-port "3005") (define sock1-port "3005")
(define sock2-port "3006") (define sock2-port "3006")
(define-c-library libc `("stdlib.h") libc-name '((additional-versions ("0" "6")))) (define-c-library libc `("stdlib.h") #f '())
(define-c-procedure c-system libc 'system 'int '(pointer)) (define-c-procedure c-system libc 'system 'int '(pointer))
(display "Testing TCP socket") (display "Testing TCP socket")
@ -13,7 +14,7 @@
;(debug (socket-domain stream)) ;(debug (socket-domain stream))
;(debug (ip-protocol ip)) ;(debug (ip-protocol ip))
(c-system (string->c-utf8 (string-append "echo \"lol\" | nc -l " sock1-port "&"))) (c-system (string->c-bytevector (string-append "echo \"lol\" | nc -l " sock1-port "&")))
(define sock1 (make-client-socket "127.0.0.1" sock1-port)) (define sock1 (make-client-socket "127.0.0.1" sock1-port))
@ -40,3 +41,4 @@
(write (utf8->string (socket-recv client-sock1 3))) (write (utf8->string (socket-recv client-sock1 3)))
(newline) (newline)
(test-end "srfi-106")

View File

@ -9,8 +9,8 @@
"pwd.h" "pwd.h"
"grp.h" "grp.h"
"fcntl.h") "fcntl.h")
libc-name #f
'((additional-versions ("0" "6")))) '())
(define-c-procedure c-perror libc 'perror 'void '(pointer)) (define-c-procedure c-perror libc 'perror 'void '(pointer))
(define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int)) (define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int))
@ -51,7 +51,7 @@
(define (random-to max) (define (random-to max)
(when (not randomized?) (when (not randomized?)
(c-srand (c-time (make-c-null))) (c-srand (c-time (c-bytevector-null)))
(set! randomized? #t)) (set! randomized? #t))
(modulo (c-rand) max)) (modulo (c-rand) max))
@ -93,25 +93,25 @@
(follow? file-info:follow?)) (follow? file-info:follow?))
(define (file-info-directory? file-info) (define (file-info-directory? file-info)
(let ((handle (c-open (string->c-utf8 (file-info:fname/port file-info)) 2))) (let ((handle (c-open (string->c-bytevector (file-info:fname/port file-info)) 2)))
(cond ((> handle 0) (c-close handle) #f) (cond ((> handle 0) (c-close handle) #f)
(else #t)))) (else #t))))
(define (file-info fname/port follow?) (define (file-info fname/port follow?)
(when (port? fname/port) (when (port? fname/port)
(error "file-info implementation does not support ports as arguments")) (error "file-info implementation does not support ports as arguments"))
(let* ((fname-pointer (string->c-utf8 fname/port)) (let* ((fname-pointer (string->c-bytevector fname/port))
(stat-pointer (make-c-bytevector 256)) (stat-pointer (make-c-bytevector 256))
(result (if follow? (result (if follow?
(c-stat fname-pointer stat-pointer) (c-stat fname-pointer stat-pointer)
(c-lstat fname-pointer stat-pointer))) (c-lstat fname-pointer stat-pointer)))
(error-message "file-info error") (error-message "file-info error")
(error-pointer (string->c-utf8 error-message))) (error-pointer (string->c-bytevector error-message)))
(when (< result 0) (when (< result 0)
(c-perror error-pointer) (c-perror error-pointer)
(c-free fname-pointer) (c-bytevector-free fname-pointer)
(c-free stat-pointer) (c-bytevector-free stat-pointer)
(c-free error-pointer) (c-bytevector-free error-pointer)
(error error-message fname/port)) (error error-message fname/port))
(make-file-info-record #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 0) (native-endianness)) (make-file-info-record #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 0) (native-endianness))
#f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 1) (native-endianness)) #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 1) (native-endianness))
@ -131,46 +131,46 @@
(define create-directory (define create-directory
(lambda (fname . permission-bits) (lambda (fname . permission-bits)
(let* ((fname-pointer (string->c-utf8 fname)) (let* ((fname-pointer (string->c-bytevector fname))
(mode (if (null? permission-bits) (mode (if (null? permission-bits)
#o775 #o775
(string->number (string-append "#o" (string->number (string-append "#o"
(number->string (car permission-bits)))))) (number->string (car permission-bits))))))
(result (c-mkdir fname-pointer mode)) (result (c-mkdir fname-pointer mode))
(error-message "create-directory error") (error-message "create-directory error")
(error-pointer (string->c-utf8 error-message))) (error-pointer (string->c-bytevector error-message)))
(c-free fname-pointer) (c-bytevector-free fname-pointer)
(when (< result 0) (when (< result 0)
(c-perror error-pointer) (c-perror error-pointer)
(c-free error-pointer) (c-bytevector-free error-pointer)
(error error-message))))) (error error-message)))))
(define (create-hard-link old-fname new-fname) (define (create-hard-link old-fname new-fname)
(c-link (string->c-utf8 old-fname) (c-link (string->c-bytevector old-fname)
(string->c-utf8 new-fname))) (string->c-bytevector new-fname)))
(define (create-symlink old-fname new-fname) (define (create-symlink old-fname new-fname)
(c-slink (string->c-utf8 old-fname) (c-slink (string->c-bytevector old-fname)
(string->c-utf8 new-fname))) (string->c-bytevector new-fname)))
(define (rename-file old-fname new-fname) (define (rename-file old-fname new-fname)
(c-rename (string->c-utf8 old-fname) (string->c-utf8 new-fname))) (c-rename (string->c-bytevector old-fname) (string->c-bytevector new-fname)))
(define (delete-directory fname) (define (delete-directory fname)
(let* ((fname-pointer (string->c-utf8 fname)) (let* ((fname-pointer (string->c-bytevector fname))
(result (c-rmdir fname-pointer)) (result (c-rmdir fname-pointer))
(error-message "delete-directory error") (error-message "delete-directory error")
(error-pointer (string->c-utf8 error-message))) (error-pointer (string->c-bytevector error-message)))
(c-free fname-pointer) (c-bytevector-free fname-pointer)
(when (< result 0) (when (< result 0)
(c-perror error-pointer) (c-perror error-pointer)
(c-free error-pointer) (c-bytevector-free error-pointer)
(error error-message)))) (error error-message))))
(define (set-file-owner fname uid gid) (define (set-file-owner fname uid gid)
(let ((fname-pointer (string->c-utf8 fname))) (let ((fname-pointer (string->c-bytevector fname)))
(c-chown fname-pointer uid gid) (c-chown fname-pointer uid gid)
(c-free fname-pointer))) (c-bytevector-free fname-pointer)))
(define (pointer-string-read pointer offset) (define (pointer-string-read pointer offset)
(letrec* ((looper (lambda (c index result) (letrec* ((looper (lambda (c index result)
@ -189,13 +189,13 @@
(define directory-files (define directory-files
(lambda (dir . dotfiles?) (lambda (dir . dotfiles?)
(letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?))) (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?)))
(path-pointer (string->c-utf8 dir)) (path-pointer (string->c-bytevector dir))
(directory-pointer (c-opendir path-pointer)) (directory-pointer (c-opendir path-pointer))
(error-message "directory-files error") (error-message "directory-files error")
(error-pointer (string->c-utf8 error-message)) (error-pointer (string->c-bytevector error-message))
(dotfile? (lambda (name) (char=? (string-ref name 0) #\.))) (dotfile? (lambda (name) (char=? (string-ref name 0) #\.)))
(looper (lambda (directory-entity files) (looper (lambda (directory-entity files)
(if (c-null? directory-entity) (if (c-bytevector-null? directory-entity)
files files
(let ((name (pointer-string-read directory-entity (let ((name (pointer-string-read directory-entity
d-name-offset))) d-name-offset)))
@ -208,30 +208,30 @@
((not (dotfile? name)) ((not (dotfile? name))
(cons name files)) (cons name files))
(else files)))))))) (else files))))))))
(when (c-null? directory-pointer) (when (c-bytevector-null? directory-pointer)
(c-perror error-pointer) (c-perror error-pointer)
;(c-free error-pointer) ;(c-bytevector-free error-pointer)
;(c-free directory) ;(c-bytevector-free directory)
;(c-free path-pointer) ;(c-bytevector-free path-pointer)
(error error-message)) (error error-message))
(let ((files (looper (c-readdir directory-pointer) (list)))) (let ((files (looper (c-readdir directory-pointer) (list))))
;(c-free error-pointer) ;(c-bytevector-free error-pointer)
;(c-free directory-pointer) ;(c-bytevector-free directory-pointer)
;(c-free path-pointer) ;(c-bytevector-free path-pointer)
(c-closedir directory-pointer) (c-closedir directory-pointer)
files)))) files))))
(define real-path (define real-path
(lambda (path) (lambda (path)
(let* ((path-pointer (string->c-utf8 path)) (let* ((path-pointer (string->c-bytevector path))
(real-path-pointer (c-realpath path-pointer (make-c-null))) (real-path-pointer (c-realpath path-pointer (c-bytevector-null)))
(real-path (string-copy (c-utf8->string real-path-pointer)))) (real-path (string-copy (c-bytevector->string real-path-pointer))))
(c-free path-pointer) (c-bytevector-free path-pointer)
(c-free real-path-pointer) (c-bytevector-free real-path-pointer)
real-path))) real-path)))
(define (set-file-mode path mode) (define (set-file-mode path mode)
(c-chmod (string->c-utf8 path) (c-chmod (string->c-bytevector path)
(string->number (string-append "#o" (number->string mode))))) (string->number (string-append "#o" (number->string mode)))))
(define-record-type <directory> (define-record-type <directory>
@ -241,14 +241,14 @@
(dot-files? directory:dot-files?)) (dot-files? directory:dot-files?))
(define (open-directory path . dot-files?) (define (open-directory path . dot-files?)
(make-directory (c-opendir (string->c-utf8 path)) (make-directory (c-opendir (string->c-bytevector path))
(if (null? dot-files?) (if (null? dot-files?)
#f #f
(car dot-files?)))) (car dot-files?))))
(define (read-directory directory-object) (define (read-directory directory-object)
(let ((directory-entity (c-readdir (directory:handle directory-object)))) (let ((directory-entity (c-readdir (directory:handle directory-object))))
(if (c-null? directory-entity) (if (c-bytevector-null? directory-entity)
(eof-object) (eof-object)
(let ((name (pointer-string-read directory-entity d-name-offset))) (let ((name (pointer-string-read directory-entity d-name-offset)))
(cond ((or (string=? name ".") (cond ((or (string=? name ".")
@ -304,12 +304,12 @@
(let* ((path-pointer (make-c-bytevector 1024)) (let* ((path-pointer (make-c-bytevector 1024))
(path (begin (path (begin
(c-getcwd path-pointer 1024) (c-getcwd path-pointer 1024)
(string-copy (c-utf8->string path-pointer))))) (string-copy (c-bytevector->string path-pointer)))))
(c-free path-pointer) (c-bytevector-free path-pointer)
path)) path))
(define (set-current-directory! path) (define (set-current-directory! path)
(c-chdir (string->c-utf8 path))) (c-chdir (string->c-bytevector path)))
(define (pid) (define (pid)
(c-getpid)) (c-getpid))
@ -339,7 +339,7 @@
)))))) ))))))
(define (user-supplementary-gids) (define (user-supplementary-gids)
(let* ((group-count (c-getgroups 0 (make-c-null))) (let* ((group-count (c-getgroups 0 (c-bytevector-null)))
(groups (make-c-bytevector (* (c-type-size 'int) group-count)))) (groups (make-c-bytevector (* (c-type-size 'int) group-count))))
(c-getgroups group-count groups) (c-getgroups group-count groups)
(groups-loop group-count 0 groups (list)))) (groups-loop group-count 0 groups (list))))
@ -357,8 +357,8 @@
(define (user-info uid/name) (define (user-info uid/name)
(let ((password-struct (if (number? uid/name) (let ((password-struct (if (number? uid/name)
(c-getpwuid uid/name) (c-getpwuid uid/name)
(c-getpwnam (string->c-utf8 uid/name))))) (c-getpwnam (string->c-bytevector uid/name)))))
(make-user-info (c-utf8->string (c-bytevector-ref password-struct (make-user-info (c-bytevector->string (c-bytevector-ref password-struct
'pointer 'pointer
0)) 0))
(c-bytevector-ref password-struct (c-bytevector-ref password-struct
@ -368,15 +368,15 @@
'int 'int
(+ (* (c-type-size 'pointer) 2) (+ (* (c-type-size 'pointer) 2)
(c-type-size 'int))) (c-type-size 'int)))
(c-utf8->string (c-bytevector-ref password-struct (c-bytevector->string (c-bytevector-ref password-struct
'pointer 'pointer
(+ (* (c-type-size 'pointer) 3) (+ (* (c-type-size 'pointer) 3)
(* (c-type-size 'int) 2)))) (* (c-type-size 'int) 2))))
(c-utf8->string (c-bytevector-ref password-struct (c-bytevector->string (c-bytevector-ref password-struct
'pointer 'pointer
(+ (* (c-type-size 'pointer) 4) (+ (* (c-type-size 'pointer) 4)
(* (c-type-size 'int) 2)))) (* (c-type-size 'int) 2))))
(c-utf8->string (c-bytevector-ref password-struct (c-bytevector->string (c-bytevector-ref password-struct
'pointer 'pointer
(+ (* (c-type-size 'pointer) 2) (+ (* (c-type-size 'pointer) 2)
(* (c-type-size 'int) 2))))))) (* (c-type-size 'int) 2)))))))
@ -391,15 +391,15 @@
(define (group-info gid/name) (define (group-info gid/name)
(let ((group-struct (if (number? gid/name) (let ((group-struct (if (number? gid/name)
(c-getgrgid gid/name) (c-getgrgid gid/name)
(c-getgrnam (string->c-utf8 gid/name))))) (c-getgrnam (string->c-bytevector gid/name)))))
(make-group-info (make-group-info
(c-utf8->string (c-bytevector-ref group-struct 'pointer 0)) (c-bytevector->string (c-bytevector-ref group-struct 'pointer 0))
(c-bytevector-ref group-struct (c-bytevector-ref group-struct
'int 'int
(* (c-type-size 'pointer) 2))))) (* (c-type-size 'pointer) 2)))))
(define (set-environment-variable! name value) (define (set-environment-variable! name value)
(c-setenv (string->c-utf8 name) (string->c-utf8 value) 1)) (c-setenv (string->c-bytevector name) (string->c-bytevector value) 1))
(define (delete-environment-variable! name) (define (delete-environment-variable! name)
(c-unsetenv (string->c-utf8 name))) (c-unsetenv (string->c-bytevector name)))

View File

@ -1,3 +1,4 @@
(test-begin "srfi-170")
(display (real-path "Makefile")) (display (real-path "Makefile"))
(newline) (newline)
@ -144,3 +145,5 @@
(display "file-info-directory? on file: ") (display "file-info-directory? on file: ")
(write (file-info-directory? tmp-file-info)) (write (file-info-directory? tmp-file-info))
(newline) (newline)
(test-begin "srfi-170")