srfi-170: Bug fixes

Dockerfile.jenkins

@@ -1,2 +1,5 @@
-FROM debian:trixie
-RUN apt-get update && apt-get -y install make docker.io git
+FROM schemers/chibi:head
+RUN apt-get update && apt-get install -y \
+    gcc ca-certificates libffi-dev docker.io make
+ARG timestamp=0
+RUN snow-chibi install --impls=chibi retropikzel.test-r7rs && echo "$timestamp"

Jenkinsfile

@@ -3,46 +3,65 @@ pipeline {
         dockerfile {
             filename 'Dockerfile.jenkins'
             label 'docker-x86_64'
-            args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
+            args '-t --user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock'
         }
     }
 
+    triggers {
+      GenericTrigger(
+        genericVariables: [[key: 'ref', value: '$.ref']],
+        causeString: 'Triggered on $ref',
+        printContributedVariables: true,
+        printPostContent: true,
+        silentResponse: false,
+        shouldNotFlatten: false,
+        regexpFilterText: '$ref',
+        regexpFilterExpression: 'refs/heads/' + BRANCH_NAME
+      )
+    }
+
     options {
         disableConcurrentBuilds()
         buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
     }
 
-    parameters {
-        string(name: 'R7RS_SCHEMES', defaultValue: 'chibi chicken gauche guile kawa mosh racket sagittarius stklos ypsilon', description: '')
-        string(name: 'R6RS_SCHEMES', defaultValue: 'chezscheme guile ikarus ironscheme mosh racket sagittarius ypsilon', description: '')
-        string(name: 'SRFIS', defaultValue: '106 170', description: '')
+    environment {
+        R7RS_SCHEMES="capyscheme chibi chicken gauche kawa mosh racket sagittarius stklos ypsilon"
+        R6RS_SCHEMES="chezscheme guile ikarus ironscheme mosh racket sagittarius ypsilon"
+        SRFIS="170"
     }
 
     stages {
-        stage('Tests') {
-            stage('R6RS x86_64 Debian') {
-                steps {
-                    script {
-                        params.SRFIS.split().each { SRFI ->
-                            params.R6RS_SCHEMES.split().each { SCHEME ->
-                                stage("${SCHEME} - ${SRFI}") {
-                                    catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
-                                        sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker"
+        stage('Parallel') {
+            parallel {
+                stage('R6RS Debian') {
+                    steps {
+                        script {
+                            env.SRFIS.split().each { SRFI ->
+                            stage("${SRFI}") {
+                                    env.R6RS_SCHEMES.split().each { SCHEME ->
+                                        stage("${SCHEME} ${SRFI}") {
+                                            catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+                                                sh "make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs test-docker"
+                                            }
+                                        }
                                     }
                                 }
                             }
                         }
                     }
                 }
-            }
-            stage('R7RS x86_64 Debian') {
-                steps {
-                    script {
-                        params.SRFIS.split().each { SRFI ->
-                            params.R7RS_SCHEMES.split().each { SCHEME ->
-                                stage("${SCHEME} - ${SRFI}") {
-                                    catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
-                                        sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker"
+                stage('R7RS Debian') {
+                    steps {
+                        script {
+                            env.SRFIS.split().each { SRFI ->
+                                stage("${SRFI}") {
+                                    env.R7RS_SCHEMES.split().each { SCHEME ->
+                                        stage("${SCHEME} ${SRFI}") {
+                                            catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+                                                sh "make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r7rs test-docker"
+                                            }
+                                        }
                                     }
                                 }
                             }

Makefile

@@ -2,6 +2,7 @@ SCHEME=chibi
 RNRS=r7rs
 SRFI=170
 AUTHOR=Retropikzel
+DOCKER_TAG=latest
 
 SRFI_FILE=srfi/${SRFI}.sld
 VERSION=$(shell cat srfi/${SRFI}/VERSION)
@@ -13,19 +14,30 @@ TMPDIR=.tmp/${SCHEME}
 PKG=srfi-${SRFI}-${VERSION}.tgz
 
 SFX=scm
+AKKU_PACKAGES=
 ifeq "${RNRS}" "r6rs"
 SFX=sps
+AKKU_PACKAGES="akku-r7rs"
 endif
 
+ifeq "${SCHEME}" "capyscheme"
 DOCKER_TAG=head
-ifeq "${SCHEME}" "chicken"
-DOCKER_TAG=5
 endif
+ifeq "${SCHEME}" "chibi"
+DOCKER_TAG=head
+endif
+ifeq "${SCHEME}" "chicken"
+DOCKER_TAG=head
+endif
+ifeq "${SCHEME}" "gauche"
+DOCKER_TAG=head
+endif
+
 
 all: package
 
 package: srfi/${SRFI}/LICENSE srfi/${SRFI}/VERSION
-	echo "<pre>$$(cat srfi/${SRFI}/README.md)</pre>" > ${README}
+	echo "<pre>$$(cat README.md)</pre>" > README.html
 	snow-chibi package \
 		--version=${VERSION} \
 		--authors=${AUTHOR} \
@@ -36,23 +48,31 @@ package: srfi/${SRFI}/LICENSE srfi/${SRFI}/VERSION
 install:
 	snow-chibi install --impls=${SCHEME} ${PKG}
 
-testfiles:
+${PKG}: package
+
+testfiles: ${PKG}
 	rm -rf .tmp
 	mkdir -p .tmp
 	cp ${PKG} .tmp
 	cp -r srfi .tmp/
-	cat test-headers.${SFX} ${TESTFILE} | sed 's/SRFI/${SRFI}/' > .tmp/test.${SFX}
+	cat test-headers.${SFX} ${TESTFILE} \
+		| sed 's/SRFI/${SRFI}/' > .tmp/test.${SFX}
 	cat ${TESTFILE} >> run-test.${SFX}
-	if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign .tmp/; fi; fi
+	if [ "${RNRS}" = "r6rs" ]; \
+		then if [ -d ../foreign-c ]; \
+		then cp -r ../foreign-c/foreign .tmp/; \
+		fi; \
+	fi
 
-test: testfiles package
+test: testfiles
 	cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX}
 	cd .tmp && ./test-program
 
-test-docker: testfiles package
+test-docker: testfiles
 	cd .tmp && \
 		DOCKER_TAG=${DOCKER_TAG} \
-		SNOW_PACKAGES="srfi.64 srfi.60 srfi.145 srfi.180 retropikzel.mouth foreign.c ${PKG}" \
+		SNOW_PACKAGES="srfi.64 ${PKG}" \
+		AKKU_PACKAGES=${AKKU_PACKAGES} \
 		APT_PACKAGES="libcurl4-openssl-dev" \
 		COMPILE_R7RS=${SCHEME} \
 		TEST_R7RS_DEBUG=1 \

srfi/170.scm

@@ -4,6 +4,7 @@
                     "string.h"
                     "dirent.h"
                     "sys/stat.h"
+                    "sys/statvfs.h"
                     "sys/types.h"
                     "unistd.h"
                     "pwd.h"
@@ -21,6 +22,7 @@
 (define-c-procedure c-lstat libc 'stat 'int '(pointer pointer))
 (define-c-procedure c-open libc 'open 'int '(pointer int))
 (define-c-procedure c-opendir libc 'opendir 'pointer '(pointer))
+(define-c-procedure c-dirfd libc 'dirfd 'int '(pointer))
 (define-c-procedure c-readdir libc 'readdir 'pointer '(pointer))
 (define-c-procedure c-close libc 'close 'int '(int))
 (define-c-procedure c-closedir libc 'closedir 'int '(pointer))
@@ -47,10 +49,51 @@
 (define-c-procedure c-link libc 'link 'int '(pointer pointer))
 (define-c-procedure c-slink libc 'link 'int '(pointer pointer))
 (define-c-procedure c-chown libc 'chown 'int '(pointer int int))
+(define-c-procedure c-clock-gettime libc 'clock_gettime 'int '(int pointer))
+(define-c-procedure c-nice libc 'nice 'int '(int))
+(define-c-procedure c-umask libc 'umask 'uint '(int))
+(define-c-procedure
+  c-utimensat libc 'utimensat 'int '(int pointer pointer int))
+(define-c-procedure c-truncate libc 'truncate 'int '(pointer int))
+(define-c-procedure c-statvfs libc 'statvfs 'int '(pointer pointer))
 
 (define slash (cond-expand (windows "\\") (else "/")))
 (define randomized? #f)
 
+(define (string-split str mark)
+  (let* ((str-l (string->list str))
+         (res (list))
+         (last-index 0)
+         (index 0)
+         (splitter
+           (lambda (c)
+             (cond ((char=? c mark)
+                    (begin
+                      (set! res
+                        (append res
+                                (list (string-copy str last-index index))))
+                      (set! last-index (+ index 1))))
+                   ((equal? (length str-l) (+ index 1))
+                    (set! res
+                      (append res
+                              (list (string-copy str
+                                                 last-index
+                                                 (+ index 1)))))))
+             (set! index (+ index 1)))))
+    (for-each splitter str-l)
+    res))
+
+(define (string-char-replace replace-in replace-this replace-with)
+  (let ((result ""))
+    (list->string
+      (for-each
+        (lambda (c)
+          (if (char=? c replace-this)
+            (set! result (string-append result replace-with))
+            (set! result (string-append result (string c)))))
+        (string->list replace-in)))
+    result))
+
 (define (random-to max)
   (when (not randomized?)
     (c-srand (c-time (c-bytevector-null)))
@@ -75,8 +118,22 @@
                              (random-to 128)))))))))
     (looper "" (random-to 128))))
 
-(define-record-type file-info-record
-  (make-file-info-record device inode mode nlinks uid gid rdev size blksize blocks atime mtime ctime fname/port follow?)
+(define-record-type <file-info>
+  (make-file-info device
+                  inode
+                  mode
+                  nlinks
+                  uid
+                  gid
+                  rdev
+                  size
+                  blksize
+                  blocks
+                  atime
+                  mtime
+                  ctime
+                  fname/port
+                  follow?)
   file-info?
   (device file-info:device)
   (inode file-info:inode)
@@ -95,105 +152,139 @@
   (follow? file-info:follow?))
 
 (define (file-info-directory? file-info)
-  (let ((handle (c-open (string->c-bytevector (file-info:fname/port file-info)) 2)))
-    (cond ((> handle 0) (c-close handle) #f)
-          (else #t))))
+  (when (not (file-info? file-info))
+    (error "file-info-directory? error: file-info must be <file-info> record"
+           file-info))
+  (let* ((file-info:fname/port*
+           (string->c-bytevector (file-info:fname/port file-info)))
+         (handle (c-open file-info:fname/port* 2))
+         (result
+           (cond ((> handle 0) (c-close handle) #f)
+                 (else #t))))
+    (c-bytevector-free file-info:fname/port*)
+    result))
 
+(define-c-struct-type stat-struct
+                      `((st_dev int)
+                        (st_ino uint)
+                        (st_mode uint)
+                        (st_nlink int)
+                        (st_uid uint)
+                        (st_gid uint)
+                        (st_rdev int)
+                        (st_size int)
+                        (st_blksize int)
+                        (st_blocks int)
+                        (st_atim.tv_sec long)
+                        (st_atim.tv_nsec long)
+                        (st_mtim.tv_sec long)
+                        (st_mtim.tv_nsec long)
+                        (st_ctim.tv_sec long)
+                        (st_ctim.tv_nsec long)))
 (define (file-info fname/port follow?)
   (when (port? fname/port)
     (error "file-info implementation does not support ports as arguments"))
-  (let* ((fname-pointer (string->c-bytevector fname/port))
-         (stat-pointer (make-c-bytevector 256))
+  (let* ((fname* (string->c-bytevector fname/port))
+         (stat* (make-c-bytevector (c-type-size stat-struct)))
          (result (if follow?
-                   (c-stat fname-pointer stat-pointer)
-                   (c-lstat fname-pointer stat-pointer)))
-         (error-message "file-info error")
-         (error-pointer (string->c-bytevector error-message)))
+                   (c-stat fname* stat*)
+                   (c-lstat fname* stat*))))
     (when (< result 0)
-      (c-perror error-pointer)
-      (c-bytevector-free fname-pointer)
-      (c-bytevector-free stat-pointer)
-      (c-bytevector-free error-pointer)
-      (error error-message fname/port))
-    (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) 2) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 3) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 4) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 5) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 6) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 7) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 8) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 9) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 10) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 11) (native-endianness))
-                           #f ;(c-bytevector-u64-ref stat-pointer (* (c-type-size 'uint64) 12) (native-endianness))
-                           fname/port
-                           follow?)))
+      (let* ((error-message "file-info error")
+             (error-msg* (string->c-bytevector error-message)))
+        (c-perror error-msg*)
+        (c-bytevector-free fname* stat* error-msg*)
+        (error error-message fname/port)))
+    (let ((file-info (make-file-info
+                (c-bytevector-ref stat* stat-struct 'st_dev)
+                (c-bytevector-ref stat* stat-struct 'st_ino)
+                (c-bytevector-ref stat* stat-struct 'st_mode)
+                (c-bytevector-ref stat* stat-struct 'st_nlink)
+                (c-bytevector-ref stat* stat-struct 'st_uid)
+                (c-bytevector-ref stat* stat-struct 'st_gid)
+                (c-bytevector-ref stat* stat-struct 'st_rdev)
+                (c-bytevector-ref stat* stat-struct 'st_size)
+                (c-bytevector-ref stat* stat-struct 'st_blksize)
+                (c-bytevector-ref stat* stat-struct 'st_blocks)
+                (make-time time-utc
+                           (c-bytevector-ref stat* stat-struct 'st_atim.tv_sec)
+                           (c-bytevector-ref stat* stat-struct 'st_atim.tv_nsec))
+                (make-time time-utc
+                           (c-bytevector-ref stat* stat-struct 'st_mtim.tv_sec)
+                           (c-bytevector-ref stat* stat-struct 'st_mtim.tv_nsec))
+                (make-time time-utc
+                           (c-bytevector-ref stat* stat-struct 'st_ctim.tv_sec)
+                           (c-bytevector-ref stat* stat-struct 'st_ctim.tv_nsec))
+                fname/port
+                follow?)))
+      (c-bytevector-free fname* stat*)
+      file-info)))
 
 (define create-directory
   (lambda (fname . permission-bits)
-    (let* ((fname-pointer (string->c-bytevector fname))
+    (let* ((fname* (string->c-bytevector fname))
            (mode (if (null? permission-bits)
                    #o775
                    (string->number
                      (string-append
                        "#o"
                        (number->string (car permission-bits))))))
-           (result (c-mkdir fname-pointer mode))
+           (result (c-mkdir fname* mode))
            (error-message "create-directory error")
-           (error-pointer (string->c-bytevector error-message)))
-      (c-bytevector-free fname-pointer)
+           (error-msg* (string->c-bytevector error-message)))
+      (c-bytevector-free fname*)
       (when (< result 0)
-        (c-perror error-pointer)
-        (c-bytevector-free error-pointer)
+        (c-perror error-msg*)
+        (c-bytevector-free error-msg*)
         (error error-message))
-      (c-bytevector-free error-pointer))))
+      (c-bytevector-free error-msg*))))
 
 (define (create-fifo fname . permission-bits)
-  (let* ((fname-pointer (string->c-bytevector fname))
+  (let* ((fname* (string->c-bytevector fname))
          (mode (if (null? permission-bits)
                  #o664
                  (string->number
                    (string-append
                      "#o"
                      (number->string (car permission-bits))))))
-         (result (c-mkfifo fname-pointer mode))
+         (result (c-mkfifo fname* mode))
          (error-message "create-fifo error")
-         (error-pointer (string->c-bytevector error-message)))
-    (c-bytevector-free fname-pointer)
+         (error-msg* (string->c-bytevector error-message)))
+    (c-bytevector-free fname*)
     (when (< result 0)
-      (c-perror error-pointer)
-      (c-bytevector-free error-pointer)
+      (c-perror error-msg*)
+      (c-bytevector-free error-msg*)
       (error error-message))
-    (c-bytevector-free error-pointer)))
+    (c-bytevector-free error-msg*)))
 
 (define (create-hard-link old-fname new-fname)
-  (c-link (string->c-bytevector old-fname)
-          (string->c-bytevector new-fname)))
+  (let ((old-fname* (string->c-bytevector old-fname))
+        (new-fname* (string->c-bytevector new-fname)))
+  (c-link old-fname* new-fname*)
+  (c-bytevector-free old-fname* new-fname*)))
 
 (define (create-symlink old-fname new-fname)
   (c-slink (string->c-bytevector old-fname)
            (string->c-bytevector new-fname)))
 
 (define (internal-read-symlink fname buffer-length)
-  (let* ((path-pointer (string->c-bytevector fname))
+  (let* ((path* (string->c-bytevector fname))
          (buffer (make-c-bytevector buffer-length))
-         (result (c-readlink path-pointer buffer (- buffer-length 1)))
+         (result (c-readlink path* buffer (- buffer-length 1)))
          (error-message "read-symlink error")
-         (error-pointer (string->c-bytevector error-message)))
+         (error-msg* (string->c-bytevector error-message)))
     (cond ((< result 0)
-           (c-perror error-pointer)
-           (c-bytevector-free error-pointer)
+           (c-perror error-msg*)
+           (c-bytevector-free error-msg*)
            (error error-message))
           ((> result buffer-length)
-           (c-bytevector-free path-pointer)
+           (c-bytevector-free path*)
            (c-bytevector-free buffer)
            (internal-read-symlink fname (+ buffer-length buffer-length)))
           (else
             (c-bytevector-set! buffer 'u8 result null-byte)
             (let ((name (c-bytevector->string buffer)))
-              (c-bytevector-free path-pointer)
+              (c-bytevector-free path*)
               (c-bytevector-free buffer)
               name)))))
 
@@ -204,20 +295,72 @@
             (string->c-bytevector new-fname)))
 
 (define (delete-directory fname)
-  (let* ((fname-pointer (string->c-bytevector fname))
-         (result (c-rmdir fname-pointer))
-         (error-message "delete-directory error")
-         (error-pointer (string->c-bytevector error-message)))
-    (c-bytevector-free fname-pointer)
+  (let* ((fname* (string->c-bytevector fname))
+         (result (c-rmdir fname*)))
+    (c-bytevector-free fname*)
     (when (< result 0)
-      (c-perror error-pointer)
-      (c-bytevector-free error-pointer)
-      (error error-message))))
+      (let* ((error-message "delete-directory error")
+             (error-msg* (string->c-bytevector error-message)))
+        (c-perror error-msg*)
+        (c-bytevector-free error-msg*)
+        (error error-message)))))
 
 (define (set-file-owner fname uid gid)
-  (let ((fname-pointer (string->c-bytevector fname)))
-    (c-chown fname-pointer uid gid)
-    (c-bytevector-free fname-pointer)))
+  (let ((fname* (string->c-bytevector fname)))
+    (c-chown fname* uid gid)
+    (c-bytevector-free fname*)))
+
+(define-c-array-type timespec-array 'long)
+(define (set-file-times fname . args)
+  (when (and (not (= (length args) 0))
+             (not (= (length args) 2)))
+    (error
+      (string-append "set-file-times error: "
+                     "It is an error if exactly one time is provided")))
+  (let* ((current-time (posix-time))
+         (access-time-object (if (null? args)
+                               current-time
+                               (car args)))
+         (modify-time-object (if (or (null? args)
+                                     (< (length args) 2))
+                               current-time
+                               (cadr args)))
+         (fname-cbv (string->c-bytevector fname))
+         (timespecs-cbv (make-c-bytevector (c-type-size* 'long 4)))
+         (current-dir-cbv (string->c-bytevector (current-directory)))
+         (current-dir-stream (c-opendir current-dir-cbv))
+         (current-dir-fd (c-dirfd current-dir-stream)))
+    (c-bytevector-set!
+      timespecs-cbv timespec-array 0 (time-second access-time-object))
+    (c-bytevector-set!
+      timespecs-cbv timespec-array 1 (time-nanosecond access-time-object))
+    (c-bytevector-set!
+      timespecs-cbv timespec-array 2 (time-second modify-time-object))
+    (c-bytevector-set!
+      timespecs-cbv timespec-array 3 (time-nanosecond modify-time-object))
+    (let ((result (c-utimensat current-dir-fd fname-cbv timespecs-cbv 0)))
+      (c-bytevector-free fname-cbv timespecs-cbv current-dir-cbv current-dir-stream)
+      (when (< result 0)
+        (let* ((error-message "set-file-times error")
+               (error-msg*(string->c-bytevector error-message)))
+          (c-perror error-msg*)
+          (c-bytevector-free error-msg*)
+          (error error-message))))))
+
+(define (truncate-file fname/port len)
+  (when (not (exact-integer? len))
+    (error "truncate-file error: len must be exact-integer"))
+  (when (not (string? fname/port))
+    (error "truncate-file error: ports not supported yet"))
+  (let* ((fname/port-cbv (string->c-bytevector fname/port))
+         (result (c-truncate fname/port-cbv len)))
+    (c-bytevector-free fname/port-cbv)
+    (when (< result 0)
+      (let* ((error-message "truncate-file error")
+             (error-msg* (string->c-bytevector error-message)))
+        (c-perror error-msg*)
+        (c-bytevector-free error-msg*)
+        (error error-message)))))
 
 (define (pointer-string-read pointer offset)
   (letrec* ((looper (lambda (c index result)
@@ -236,17 +379,17 @@
 (define directory-files
   (lambda (dir . dotfiles?)
     (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?)))
-              (path-pointer (string->c-bytevector dir))
-              (directory-pointer (c-opendir path-pointer))
+              (path* (string->c-bytevector dir))
+              (directory* (c-opendir path*))
               (error-message "directory-files error")
-              (error-pointer (string->c-bytevector error-message))
+              (error-msg* (string->c-bytevector error-message))
               (dotfile? (lambda (name) (char=? (string-ref name 0) #\.)))
               (looper (lambda (directory-entity files)
                         (if (c-bytevector-null? directory-entity)
                           files
                           (let ((name (pointer-string-read directory-entity
                                                            d-name-offset)))
-                            (looper (c-readdir directory-pointer)
+                            (looper (c-readdir directory*)
                                     (cond ((string=? name ".") files)
                                           ((string=? name "..") files)
                                           ((and include-dotfiles?
@@ -255,28 +398,19 @@
                                           ((not (dotfile? name))
                                            (cons name files))
                                           (else files))))))))
-      (when (c-bytevector-null? directory-pointer)
-        (c-perror error-pointer)
-        ;(c-bytevector-free error-pointer)
-        ;(c-bytevector-free directory)
-        ;(c-bytevector-free path-pointer)
+      (when (c-bytevector-null? directory*)
+        (c-perror error-msg*)
+        ;(c-bytevector-free error-msg*)
+        ;(c-bytevector-free directory*)
+        ;(c-bytevector-free path*)
         (error error-message))
-      (let ((files (looper (c-readdir directory-pointer) (list))))
-        ;(c-bytevector-free error-pointer)
-        ;(c-bytevector-free directory-pointer)
-        ;(c-bytevector-free path-pointer)
-        (c-closedir directory-pointer)
+      (let ((files (looper (c-readdir directory*) (list))))
+        ;(c-bytevector-free error-msg*)
+        ;(c-bytevector-free directory*)
+        ;(c-bytevector-free path*)
+        (c-closedir directory*)
         files))))
 
-(define real-path
-  (lambda (path)
-    (let* ((path-pointer (string->c-bytevector path))
-           (real-path-pointer (c-realpath path-pointer (c-bytevector-null)))
-           (real-path (string-copy (c-bytevector->string real-path-pointer))))
-      (c-bytevector-free path-pointer)
-      (c-bytevector-free real-path-pointer)
-      real-path)))
-
 (define (set-file-mode path mode)
   (c-chmod (string->c-bytevector path)
            (string->number (string-append "#o" (number->string mode)))))
@@ -311,6 +445,15 @@
 (define (close-directory directory-object)
   (c-closedir (directory:handle directory-object)))
 
+(define real-path
+  (lambda (path)
+    (let* ((path* (string->c-bytevector path))
+           (real-path* (c-realpath path* (c-bytevector-null)))
+           (real-path (string-copy (c-bytevector->string real-path*))))
+      (c-bytevector-free path*)
+      (c-bytevector-free real-path*)
+      real-path)))
+
 (define temp-file-prefix
   (make-parameter
     (if (get-environment-variable "TMPDIR")
@@ -327,9 +470,10 @@
     (let* ((tmpdir (cond-expand
                      (windows (get-environment-variable "TMP"))
                      (else "/tmp")))
-           (real-prefix (if (null? prefix)
-                          (string-append tmpdir slash (number->string (c-getpid)))
-                          (car prefix)))
+           (real-prefix
+             (if (null? prefix)
+               (string-append tmpdir slash (number->string (c-getpid)))
+               (car prefix)))
            (path (string-append real-prefix "-" (random-string 6))))
       (if (file-exists? path)
         (create-temp-file real-prefix)
@@ -342,48 +486,60 @@
   (let* ((tmpdir (cond-expand (windows (get-environment-variable "TMP"))
                               (else "/tmp")))
          (real-prefix (if (null? prefix)
-                        (string-append tmpdir slash (number->string (c-getpid)))
+                        (string-append tmpdir
+                                       slash
+                                       (number->string (c-getpid)))
                         (car prefix)))
          (path (string-append real-prefix "-" (random-string 6))))
     (apply maker (list path))))
 
+(define (umask)
+  (let ((mask (c-umask 0)))
+    (c-umask mask)
+    mask))
+
+(define (set-umask! umask)
+  (c-umask umask))
+
 (define (current-directory)
-  (let* ((path-pointer (make-c-bytevector 1024))
+  (let* ((path* (make-c-bytevector 1024))
          (path (begin
-                 (c-getcwd path-pointer 1024)
-                 (string-copy (c-bytevector->string path-pointer)))))
-    (c-bytevector-free path-pointer)
+                 (c-getcwd path* 1024)
+                 (string-copy (c-bytevector->string path*)))))
+    (c-bytevector-free path*)
     path))
 
 (define (set-current-directory! path)
   (c-chdir (string->c-bytevector path)))
 
-(define (pid)
-  (c-getpid))
+(define (pid) (c-getpid))
 
-(define (user-uid)
-  (c-getuid))
+(define nice
+  (lambda args
+    (let ((result (if (null? args) (c-nice 1) (c-nice (car args)))))
+      (when (< result 0)
+        (let* ((error-message "nice error")
+               (error-msg* (string->c-bytevector error-message)))
+          (c-perror error-msg*)
+          (c-bytevector-free timespec)
+          (c-bytevector-free error-msg*)
+          (error error-message)))
+      result)))
+(define (user-uid) (c-getuid))
+(define (user-gid) (c-getgid))
+(define (user-effective-uid) (c-geteuid))
+(define (user-effective-gid) (c-getegid))
 
-(define (user-gid)
-  (c-getgid))
-
-(define (user-effective-uid)
-  (c-geteuid))
-
-(define (user-effective-gid)
-  (c-getegid))
-
-(define (groups-loop max-count count groups-pointer result)
+(define (groups-loop max-count count groups* result)
   (if (>= count max-count)
     result
     (groups-loop max-count
                  (+ count 1)
-                 groups-pointer
+                 groups*
                  (append result
-                         (list (c-bytevector-ref groups-pointer
+                         (list (c-bytevector-ref groups*
                                                  'int
-                                                 (* (c-type-size 'int) count)
-                                                 ))))))
+                                                 (* (c-type-size 'int) count)))))))
 
 (define (user-supplementary-gids)
   (let* ((group-count (c-getgroups 0 (c-bytevector-null)))
@@ -394,17 +550,40 @@
 (define-record-type <user-info>
   (make-user-info name uid gid home-dir shell full-name)
   user-info?
-  (name user-info:name)
-  (uid user-info:uid)
-  (gid user-info:gid)
-  (home-dir user-info:home-dir)
-  (shell user-info:shell)
-  (full-name user-info:full-name))
+  (name internal-user-info:name)
+  (uid internal-user-info:uid)
+  (gid internal-user-info:gid)
+  (home-dir internal-user-info:home-dir)
+  (shell internal-user-info:shell)
+  (full-name internal-user-info:full-name))
+
+(define (user-info:name user-info) (internal-user-info:name user-info))
+(define (user-info:uid user-info) (internal-user-info:uid user-info))
+(define (user-info:gid user-info) (internal-user-info:gid user-info))
+(define (user-info:home-dir user-info) (internal-user-info:home-dir user-info))
+(define (user-info:shell user-info) (internal-user-info:shell user-info))
+
+(define (user-info:full-name user-info)
+  (internal-user-info:full-name user-info))
+
+(define (user-info:parsed-full-name user-info)
+  (let* ((parsed-list
+           (string-split (internal-user-info:full-name user-info) #\,))
+         (first
+           (string-append
+             (string (char-upcase (string-ref (car parsed-list) 0)))
+             (string-copy (car parsed-list) 1))))
+    (cons (string-char-replace first #\& (user-info:name user-info))
+          (cdr parsed-list))))
 
 (define (user-info uid/name)
   (let ((password-struct (if (number? uid/name)
                            (c-getpwuid uid/name)
-                           (c-getpwnam (string->c-bytevector uid/name)))))
+                           (let*
+                             ((uid/name* (string->c-bytevector uid/name))
+                              (result (c-getpwnam uid/name*)))
+                             (c-bytevector-free uid/name*)
+                             result))))
     (make-user-info (c-bytevector->string (c-bytevector-ref password-struct
                                                             'pointer
                                                             0))
@@ -446,7 +625,57 @@
                         (* (c-type-size 'pointer) 2)))))
 
 (define (set-environment-variable! name value)
-  (c-setenv (string->c-bytevector name) (string->c-bytevector value) 1))
+  (when (not (string? name))
+    (error "set-environment-variable! error: name must be string"))
+  (when (not (string? value))
+    (error "set-environment-variable! error: value must be string"))
+  (let ((name* (string->c-bytevector name))
+        (value* (string->c-bytevector value)))
+  (c-setenv name* value* 1)
+  (c-bytevector-free name* value*)))
 
 (define (delete-environment-variable! name)
+  (when (not (string? name))
+    (error "delete-environment-variable! error: Name must be string"))
   (c-unsetenv (string->c-bytevector name)))
+
+(define CLOCK_REALTIME 0)
+(define CLOCK_MONOTONIC 1)
+(define tv_sec-type 'long)
+(define tv_nsec-type 'long)
+(define timespec (make-c-bytevector (c-type-size+ tv_sec-type tv_nsec-type)))
+
+(define (posix-time)
+  (let* ((result (c-clock-gettime CLOCK_REALTIME timespec)))
+    (cond
+      ((< result 0)
+       (let* ((error-message "posix-time error")
+              (error-msg* (string->c-bytevector error-message)))
+         (c-perror error-msg*)
+         (c-bytevector-free timespec)
+         (c-bytevector-free error-msg*)
+         (error error-message)))
+      (else
+        (make-time time-utc
+                   (c-bytevector-ref timespec
+                                     tv_nsec-type
+                                     (c-type-size tv_sec-type))
+                   (c-bytevector-ref timespec tv_sec-type 0))))))
+
+(define (monotonic-time)
+  (let* ((result (c-clock-gettime CLOCK_MONOTONIC timespec)))
+    (cond
+      ((< result 0)
+       (let* ((error-message "posix-time error")
+              (error-msg* (string->c-bytevector error-message)))
+         (c-perror error-msg*)
+         (c-bytevector-free timespec)
+         (c-bytevector-free error-msg*)
+         (error error-message)))
+      (else
+        (make-time time-utc
+                   (c-bytevector-ref timespec
+                                     tv_nsec-type
+                                     (c-type-size tv_sec-type))
+                   (c-bytevector-ref timespec tv_sec-type 0))))))
+

srfi/170.sld

@@ -5,7 +5,8 @@
           (scheme write)
           (scheme file)
           (scheme process-context)
-          (foreign c))
+          (foreign c)
+          (srfi 19))
   (export ;posix-error?
           ;posix-error-name
           ;posix-error-message
@@ -19,23 +20,23 @@
           rename-file
           delete-directory
           set-file-owner
-          ;set-file-times
-          ;truncate-file
+          set-file-times
+          truncate-file
           file-info
           file-info?
-          ;file-info:device
-          ;file-info:inode
-          ;file-info:mode
-          ;file-info:nlinks
-          ;file-info:uid
-          ;file-info:gid
-          ;file-info:rdev
-          ;file-info:size
-          ;file-info:blksize
-          ;file-info:blocks
-          ;file-info:atime
-          ;file-info:mtime
-          ;file-info:ctime
+          file-info:device
+          file-info:inode
+          file-info:mode
+          file-info:nlinks
+          file-info:uid
+          file-info:gid
+          file-info:rdev
+          file-info:size
+          file-info:blksize
+          file-info:blocks
+          file-info:atime
+          file-info:mtime
+          file-info:ctime
           file-info-directory?
           ;file-info-fifo?
           ;file-info-symlink?
@@ -48,17 +49,17 @@
           open-directory
           read-directory
           close-directory
-          ;real-path
+          real-path
           ;file-space
           temp-file-prefix
           create-temp-file
           call-with-temporary-filename
-          ;umask
-          ;set-umask!
+          umask
+          set-umask!
           current-directory
           set-current-directory!
           pid
-          ;nice
+          nice
           user-uid
           user-gid
           user-effective-uid
@@ -72,13 +73,13 @@
           user-info:home-dir
           user-info:shell
           user-info:full-name
-          ;user-info:parsed-full-name
+          user-info:parsed-full-name
           group-info
           group-info?
           group-info:name
           group-info:gid
-          ;posix-time
-          ;monotonic-time
+          posix-time
+          monotonic-time
           set-environment-variable!
           delete-environment-variable!
           ;terminal?

srfi/170/README.md

@@ -1,83 +1,9 @@
-Implementation of [SRFI 170](https://srfi.schemers.org/srfi-170/srfi-170.html)
-POSIX API using (foreign c)].
+Implementation of SRFI 170 - POSIX API using (foreign c)
+
+Not everything is implemented yet, see 170.sld for commented out parts
 
 Currently only supports Linux.
 
-Uncommented things here are implemented.
+## Documentation
 
-    ;;;;posix-error?
-    ;;;;posix-error-name
-    ;;;;posix-error-message
-    ;;;;open-file
-    ;;;;fd->port
-    create-directory
-    ;;;;create-fifo
-    create-hard-link
-    create-symlink
-    ;;;;read-symlink
-    ;;;;rename-file
-    delete-directory
-    ;;;;set-file-owner
-    ;;;;set-file-times
-    ;;;;truncate-file
-    file-info
-    file-info?
-    ;;;;file-info:device
-    ;;;;file-info:inode
-    ;;;;file-info:mode
-    ;;;;file-info:nlinks
-    ;;;;file-info:uid
-    ;;;;file-info:gid
-    ;;;;file-info:rdev
-    ;;;;file-info:size
-    ;;;;file-info:blksize
-    ;;;;file-info:blocks
-    ;;;;file-info:atime
-    ;;;;file-info:mtime
-    ;;;;file-info:ctime
-    file-info-directory?
-    ;;;;file-info-fifo?
-    ;;;;file-info-symlink?
-    ;;;;file-info-regular?
-    ;;;;file-info-socket?
-    ;;;;file-info-device?
-    set-file-mode
-    directory-files
-    ;;;;make-directory-files-generator
-    open-directory
-    read-directory
-    close-directory
-    real-path
-    ;;;;file-space
-    temp-file-prefix
-    create-temp-file
-    call-with-temporary-filename
-    ;;;;umask
-    ;;;;set-umask!
-    current-directory
-    set-current-directory!
-    pid
-    ;;;;nice
-    user-uid
-    user-gid
-    user-effective-uid
-    user-effective-gid
-    user-supplementary-gids
-    user-info
-    user-info?
-    user-info:name
-    user-info:uid
-    user-info:gid
-    user-info:home-dir
-    user-info:shell
-    user-info:full-name
-    ;;;;user-info:parsed-full-name
-    group-info
-    group-info?
-    group-info:name
-    group-info:gid
-    ;;;;posix-time
-    ;;;;monotonic-time
-    set-environment-variable!
-    delete-environment-variable!
-    ;;;;terminal?
+See [https://srfi.schemers.org/srfi-170/srfi-170.html](https://srfi.schemers.org/srfi-170/srfi-170.html)

srfi/170/VERSION

@@ -1 +1 @@
-0.1.4
+0.2.4

srfi/170/test.scm

@@ -1,12 +1,30 @@
 (test-begin "srfi-170")
 
-;(display (real-path "Makefile"))
-;(newline)
+(write (posix-time))
+(newline)
 
-;(exit 0)
+(write (monotonic-time))
+(newline)
 
+(define niceness (nice 1))
+(test-assert (number? niceness))
+(test-assert (> niceness 0))
+
+(define fi (file-info "/tmp" #f))
+(write fi)
+(newline)
+(write (file-info:mode fi))
+(newline)
+
+
+#|
 (define tmp-dir "/tmp/foreign-c-srfi-170")
-(when (file-exists? tmp-dir) (delete-directory tmp-dir))
+(for-each
+  (lambda (file)
+    (delete-file (string-append tmp-dir "/" file)))
+  (directory-files tmp-dir #t))
+(when (file-exists? tmp-dir)
+  (delete-directory tmp-dir))
 (create-directory tmp-dir)
 
 (define tmp-file (string-append tmp-dir "/test.txt"))
@@ -145,5 +163,7 @@
 (display "file-info-directory? on file: ")
 (write (file-info-directory? tmp-file-info))
 (newline)
+|#
 
-(test-begin "srfi-170")
+
+(test-end "srfi-170")

test-headers.sps

@@ -1,4 +1,4 @@
 (import (rnrs)
         (srfi :64)
         (foreign c)
-        (srfi SRFI))
+        (srfi :SRFI))