diff --git a/.gitignore b/.gitignore
index 7a80de4..9f4f8f0 100644
--- a/.gitignore
+++ b/.gitignore
@@ -5,4 +5,6 @@ venv
foreign
run-test*
.*
-
+test-program
+*.link
+!.snow-repo.scm
diff --git a/.snow-repo.scm b/.snow-repo.scm
new file mode 100644
index 0000000..73eabac
--- /dev/null
+++ b/.snow-repo.scm
@@ -0,0 +1,36 @@
+(repository
+ (package
+ (git
+ (hash "02c5fa06cab2ea15fe25fbd6433a8a549ee5d18f")
+ (url "https://codeberg.org/retropikzel/foreign-c-srfis.git"))
+ (authors "Retropikzel")
+ (version "0.2.5")
+ (license LGPL-3.0-or-later)
+ (library
+ (name
+ (srfi 170))
+ (path "srfi/170.sld")
+ (foreign-depends)
+ (depends
+ (scheme base)
+ (scheme char)
+ (scheme write)
+ (scheme file)
+ (scheme process-context)
+ (foreign c)
+ (srfi 19)))
+ (manual "srfi/170/index.html")
+ (description "(foreign c) SRFI 170: POSIX API")
+ (test "srfi/170/test.scm")
+ (test-depends
+ (scheme base)
+ (scheme write)
+ (scheme read)
+ (scheme char)
+ (scheme file)
+ (scheme process-context)
+ (retropikzel tap)
+ (foreign c)
+ (srfi 64)
+ (srfi 170))
+ (updated "2026-08-29T15:04:01+00:00")))
diff --git a/Dockerfile.jenkins b/Dockerfile.jenkins
index 91b0707..6a2a454 100644
--- a/Dockerfile.jenkins
+++ b/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"
diff --git a/Jenkinsfile b/Jenkinsfile
index fc09848..5f36019 100644
--- a/Jenkinsfile
+++ b/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"
+ }
+ }
}
}
}
diff --git a/Makefile b/Makefile
index e380a5b..3f7cf8e 100644
--- a/Makefile
+++ b/Makefile
@@ -1,60 +1,49 @@
+.POSIX:
+.DEFAULT: all
SCHEME=chibi
-RNRS=r7rs
SRFI=170
-AUTHOR=Retropikzel
-
-SRFI_FILE=srfi/${SRFI}.sld
-VERSION=$(shell cat srfi/${SRFI}/VERSION)
-DESCRIPTION=$(shell head -n1 srfi/${SRFI}/README.md)
-README=srfi/${SRFI}/README.html
-TESTFILE=srfi/${SRFI}/test.scm
-TMPDIR=.tmp/${SCHEME}
-
PKG=srfi-${SRFI}-${VERSION}.tgz
-
-SFX=scm
-ifeq "${RNRS}" "r6rs"
-SFX=sps
-endif
-
-DOCKER_TAG=head
-ifeq "${SCHEME}" "chicken"
-DOCKER_TAG=5
-endif
+VERSION=$$(cat srfi/${SRFI}/VERSION)
+TESTFILE=srfi/${SRFI}/test.scm
+DOCFILE=srfi/${SRFI}/index.html
all: package
package: srfi/${SRFI}/LICENSE srfi/${SRFI}/VERSION
- echo "$$(cat srfi/${SRFI}/README.md)" > ${README}
+ cp srfi/${SRFI}/test.scm test.scm
snow-chibi package \
- --version=${VERSION} \
- --authors=${AUTHOR} \
- --doc=${README} \
- --description="${DESCRIPTION}" \
- ${SRFI_FILE}
+ --license="$$(cat srfi/${SRFI}/LICENSE)" \
+ --version="${VERSION}" \
+ --authors="$$(cat srfi/${SRFI}/AUTHORS 2>/dev/null || echo 'Retropikzel')" \
+ --doc=${DOCFILE} \
+ --test=${TESTFILE} \
+ --description="$$(cat srfi/${SRFI}/DESCRIPTION)" \
+ srfi/${SRFI}.sld
+
+git-index: package
+ snow-chibi git-index ${PKG}
install:
- snow-chibi install --impls=${SCHEME} ${PKG}
+ snow-chibi install --impls=${SCHEME} --skip-tests?=1 ${PKG}
-testfiles:
- 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 ${TESTFILE} >> run-test.${SFX}
- if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign .tmp/; fi; fi
+test:
+ cp srfi/${SRFI}/test.scm test.scm
+ COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.scm
+ ./test-program
-test: testfiles package
- cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX}
- cd .tmp && ./test-program
+test-docker: testfiles
+ DOCKER_TAG=${DOCKER_TAG} \
+ SNOW_PACKAGES="srfi.64 ${PKG}" \
+ AKKU_PACKAGES=${AKKU_PACKAGES} \
+ APT_PACKAGES="libcurl4-openssl-dev" \
+ COMPILE_R7RS=${SCHEME} \
+ TEST_R7RS_DEBUG=1 \
+ CSC_OPIONS="-L -lcurl" \
+ test-r7rs -o test-program test.scm
-test-docker: testfiles package
- cd .tmp && \
- DOCKER_TAG=${DOCKER_TAG} \
- SNOW_PACKAGES="srfi.64 srfi.60 srfi.145 srfi.180 retropikzel.mouth foreign.c ${PKG}" \
- APT_PACKAGES="libcurl4-openssl-dev" \
- COMPILE_R7RS=${SCHEME} \
- TEST_R7RS_DEBUG=1 \
- CSC_OPIONS="-L -lcurl" \
- test-r7rs -o test-program test.${SFX}
+update-info:
+ curl -L -o srfi/${SRFI}/index.html https://srfi.schemers.org/srfi-${SRFI}/srfi-${SRFI}.html
+ printf "(foreign c) $$(cat srfi/${SRFI}/index.html | grep '' | sed 's/<title>//' | sed 's/<\/title>//' | sed 's/^[ \t]*//' | tr -d '\n')" > srfi/${SRFI}/DESCRIPTION
+
+clean:
+ git clean -X -f
diff --git a/README.md b/README.md
index 276b247..e4f7680 100644
--- a/README.md
+++ b/README.md
@@ -1,7 +1,27 @@
-To install SRFI library run
+# (foreign c) SRFis
+
+SRFIs made using [(foreign c)](https://codeberg.org/foreign-c/foreign-c) library.
+
+
+## SRFI-106: Basic socket interface
+
+Prioritazing TCP client sockets.
+
+## SRFI-170: POSIX API
+
+
+## Installation
+
+To install published SRFI run:
+
+ snow-fort install --impls=chibi srfi.N
+
+
+To install SRFI from this repository run:
make SCHEME=chibi SRFI=106 build install
-Change chibi to any other implementation supported by snow-chibi, and 106
-to any filename without suffix in srfi/*.sld
+## Usage
+
+Import and use.
diff --git a/srfi/106.scm b/srfi/106.scm
index 6a08391..f855779 100644
--- a/srfi/106.scm
+++ b/srfi/106.scm
@@ -83,10 +83,7 @@
(ai-flags (if (>= (length args) 3)
(list-ref args 2)
(socket-merge-flags *ai-v4mapped* *ai-addrconfig*)))
- (ai-protocol
- (if (>= (length args) 4)
- (list-ref args 3)
- *ipproto-ip*)))
+ (ai-protocol (if (>= (length args) 4) (list-ref args 3) *ipproto-ip*)))
(let* ((ai-family-offset (c-type-size 'int))
(ai-socktype-offset (* (c-type-size 'int) 2))
(ai-protocol-offset (* (c-type-size 'int) 3))
@@ -149,9 +146,21 @@
names))))
(define (socket-send socket bv . flags)
+ (display "HERE :")
+ (write socket)
+ (newline)
+ (write bv)
+ (newline)
+ (display "HERE :")
+ (write socket)
+ (newline)
+ (write bv)
+ (newline)
(let* ((msg (bytevector->c-bytevector bv))
(msg-len (bytevector-length bv))
(sent-count (c-send (socket-file-descriptor socket) msg msg-len 0)))
+ (display sent-count)
+ (newline)
(when (= sent-count -1)
(c-perror (string->c-bytevector "socket-send error"))
(raise-continuable "socket-send error"))
diff --git a/srfi/106/DESCRIPTION b/srfi/106/DESCRIPTION
new file mode 100644
index 0000000..5ff20d7
--- /dev/null
+++ b/srfi/106/DESCRIPTION
@@ -0,0 +1 @@
+(foreign c) SRFI 106: Basic socket interface
\ No newline at end of file
diff --git a/srfi/106/LICENSE b/srfi/106/LICENSE
index 0a04128..447ad67 100644
--- a/srfi/106/LICENSE
+++ b/srfi/106/LICENSE
@@ -1,165 +1 @@
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-
- This version of the GNU Lesser General Public License incorporates
-the terms and conditions of version 3 of the GNU General Public
-License, supplemented by the additional permissions listed below.
-
- 0. Additional Definitions.
-
- As used herein, "this License" refers to version 3 of the GNU Lesser
-General Public License, and the "GNU GPL" refers to version 3 of the GNU
-General Public License.
-
- "The Library" refers to a covered work governed by this License,
-other than an Application or a Combined Work as defined below.
-
- An "Application" is any work that makes use of an interface provided
-by the Library, but which is not otherwise based on the Library.
-Defining a subclass of a class defined by the Library is deemed a mode
-of using an interface provided by the Library.
-
- A "Combined Work" is a work produced by combining or linking an
-Application with the Library. The particular version of the Library
-with which the Combined Work was made is also called the "Linked
-Version".
-
- The "Minimal Corresponding Source" for a Combined Work means the
-Corresponding Source for the Combined Work, excluding any source code
-for portions of the Combined Work that, considered in isolation, are
-based on the Application, and not on the Linked Version.
-
- The "Corresponding Application Code" for a Combined Work means the
-object code and/or source code for the Application, including any data
-and utility programs needed for reproducing the Combined Work from the
-Application, but excluding the System Libraries of the Combined Work.
-
- 1. Exception to Section 3 of the GNU GPL.
-
- You may convey a covered work under sections 3 and 4 of this License
-without being bound by section 3 of the GNU GPL.
-
- 2. Conveying Modified Versions.
-
- If you modify a copy of the Library, and, in your modifications, a
-facility refers to a function or data to be supplied by an Application
-that uses the facility (other than as an argument passed when the
-facility is invoked), then you may convey a copy of the modified
-version:
-
- a) under this License, provided that you make a good faith effort to
- ensure that, in the event an Application does not supply the
- function or data, the facility still operates, and performs
- whatever part of its purpose remains meaningful, or
-
- b) under the GNU GPL, with none of the additional permissions of
- this License applicable to that copy.
-
- 3. Object Code Incorporating Material from Library Header Files.
-
- The object code form of an Application may incorporate material from
-a header file that is part of the Library. You may convey such object
-code under terms of your choice, provided that, if the incorporated
-material is not limited to numerical parameters, data structure
-layouts and accessors, or small macros, inline functions and templates
-(ten or fewer lines in length), you do both of the following:
-
- a) Give prominent notice with each copy of the object code that the
- Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the object code with a copy of the GNU GPL and this license
- document.
-
- 4. Combined Works.
-
- You may convey a Combined Work under terms of your choice that,
-taken together, effectively do not restrict modification of the
-portions of the Library contained in the Combined Work and reverse
-engineering for debugging such modifications, if you also do each of
-the following:
-
- a) Give prominent notice with each copy of the Combined Work that
- the Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the Combined Work with a copy of the GNU GPL and this license
- document.
-
- c) For a Combined Work that displays copyright notices during
- execution, include the copyright notice for the Library among
- these notices, as well as a reference directing the user to the
- copies of the GNU GPL and this license document.
-
- d) Do one of the following:
-
- 0) Convey the Minimal Corresponding Source under the terms of this
- License, and the Corresponding Application Code in a form
- suitable for, and under terms that permit, the user to
- recombine or relink the Application with a modified version of
- the Linked Version to produce a modified Combined Work, in the
- manner specified by section 6 of the GNU GPL for conveying
- Corresponding Source.
-
- 1) Use a suitable shared library mechanism for linking with the
- Library. A suitable mechanism is one that (a) uses at run time
- a copy of the Library already present on the user's computer
- system, and (b) will operate properly with a modified version
- of the Library that is interface-compatible with the Linked
- Version.
-
- e) Provide Installation Information, but only if you would otherwise
- be required to provide such information under section 6 of the
- GNU GPL, and only to the extent that such information is
- necessary to install and execute a modified version of the
- Combined Work produced by recombining or relinking the
- Application with a modified version of the Linked Version. (If
- you use option 4d0, the Installation Information must accompany
- the Minimal Corresponding Source and Corresponding Application
- Code. If you use option 4d1, you must provide the Installation
- Information in the manner specified by section 6 of the GNU GPL
- for conveying Corresponding Source.)
-
- 5. Combined Libraries.
-
- You may place library facilities that are a work based on the
-Library side by side in a single library together with other library
-facilities that are not Applications and are not covered by this
-License, and convey such a combined library under terms of your
-choice, if you do both of the following:
-
- a) Accompany the combined library with a copy of the same work based
- on the Library, uncombined with any other library facilities,
- conveyed under the terms of this License.
-
- b) Give prominent notice with the combined library that part of it
- is a work based on the Library, and explaining where to find the
- accompanying uncombined form of the same work.
-
- 6. Revised Versions of the GNU Lesser General Public License.
-
- The Free Software Foundation may publish revised and/or new versions
-of the GNU Lesser General Public License from time to time. Such new
-versions will be similar in spirit to the present version, but may
-differ in detail to address new problems or concerns.
-
- Each version is given a distinguishing version number. If the
-Library as you received it specifies that a certain numbered version
-of the GNU Lesser General Public License "or any later version"
-applies to it, you have the option of following the terms and
-conditions either of that published version or of any later version
-published by the Free Software Foundation. If the Library as you
-received it does not specify a version number of the GNU Lesser
-General Public License, you may choose any version of the GNU Lesser
-General Public License ever published by the Free Software Foundation.
-
- If the Library as you received it specifies that a proxy can decide
-whether future versions of the GNU Lesser General Public License shall
-apply, that proxy's public statement of acceptance of any version is
-permanent authorization for you to choose that version for the
-Library.
+LGPL-3.0-or-later
diff --git a/srfi/106/test.scm b/srfi/106/test.scm
index 54ccc51..23c658d 100644
--- a/srfi/106/test.scm
+++ b/srfi/106/test.scm
@@ -1,5 +1,33 @@
-(test-begin "srfi-106")
+(import (scheme base)
+ (scheme write)
+ (scheme read)
+ (scheme char)
+ (scheme file)
+ (scheme process-context)
+ (retropikzel tap)
+ (foreign c)
+ (srfi 64)
+ (srfi 106))
+(test-runner-current (tap-runner))
+
+(test-begin "106")
+
+
+(test-begin "TCP Client")
+
+(test-begin "URL")
+(let ((sock (make-client-socket "tcpbin.com" "4242"))
+ (msg "Hello world!"))
+ (socket-send sock (string->utf8 msg))
+ (test-equal msg (utf8->string (socket-recv sock (string-length msg))))
+ (socket-close))
+(test-begin "URL")
+
+(test-end "TCP Client")
+
+
+#|
(define sock1-port "3005")
(define sock2-port "3006")
@@ -41,4 +69,6 @@
(write (utf8->string (socket-recv client-sock1 3)))
(newline)
-(test-end "srfi-106")
+|#
+
+(test-end "106")
diff --git a/srfi/170.scm b/srfi/170.scm
index ffaa50f..a48e309 100644
--- a/srfi/170.scm
+++ b/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,129 +152,215 @@
(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))
- (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)))
+ (let* ((fname* (string->c-bytevector fname/port))
+ (stat* (make-c-bytevector (c-type-size stat-struct)))
+ (result (if follow? (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)))))
(define (read-symlink fname) (internal-read-symlink fname 128))
(define (rename-file old-fname new-fname)
- (c-rename (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-rename old-fname* new-fname*)
+ (c-bytevector-free old-fname* 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))))))
+
diff --git a/srfi/170.sld b/srfi/170.sld
index 898cead..6b5920a 100644
--- a/srfi/170.sld
+++ b/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?
diff --git a/srfi/170/DESCRIPTION b/srfi/170/DESCRIPTION
new file mode 100644
index 0000000..911aefd
--- /dev/null
+++ b/srfi/170/DESCRIPTION
@@ -0,0 +1 @@
+(foreign c) SRFI 170: POSIX API
\ No newline at end of file
diff --git a/srfi/170/LICENSE b/srfi/170/LICENSE
index 0a04128..447ad67 100644
--- a/srfi/170/LICENSE
+++ b/srfi/170/LICENSE
@@ -1,165 +1 @@
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-
- This version of the GNU Lesser General Public License incorporates
-the terms and conditions of version 3 of the GNU General Public
-License, supplemented by the additional permissions listed below.
-
- 0. Additional Definitions.
-
- As used herein, "this License" refers to version 3 of the GNU Lesser
-General Public License, and the "GNU GPL" refers to version 3 of the GNU
-General Public License.
-
- "The Library" refers to a covered work governed by this License,
-other than an Application or a Combined Work as defined below.
-
- An "Application" is any work that makes use of an interface provided
-by the Library, but which is not otherwise based on the Library.
-Defining a subclass of a class defined by the Library is deemed a mode
-of using an interface provided by the Library.
-
- A "Combined Work" is a work produced by combining or linking an
-Application with the Library. The particular version of the Library
-with which the Combined Work was made is also called the "Linked
-Version".
-
- The "Minimal Corresponding Source" for a Combined Work means the
-Corresponding Source for the Combined Work, excluding any source code
-for portions of the Combined Work that, considered in isolation, are
-based on the Application, and not on the Linked Version.
-
- The "Corresponding Application Code" for a Combined Work means the
-object code and/or source code for the Application, including any data
-and utility programs needed for reproducing the Combined Work from the
-Application, but excluding the System Libraries of the Combined Work.
-
- 1. Exception to Section 3 of the GNU GPL.
-
- You may convey a covered work under sections 3 and 4 of this License
-without being bound by section 3 of the GNU GPL.
-
- 2. Conveying Modified Versions.
-
- If you modify a copy of the Library, and, in your modifications, a
-facility refers to a function or data to be supplied by an Application
-that uses the facility (other than as an argument passed when the
-facility is invoked), then you may convey a copy of the modified
-version:
-
- a) under this License, provided that you make a good faith effort to
- ensure that, in the event an Application does not supply the
- function or data, the facility still operates, and performs
- whatever part of its purpose remains meaningful, or
-
- b) under the GNU GPL, with none of the additional permissions of
- this License applicable to that copy.
-
- 3. Object Code Incorporating Material from Library Header Files.
-
- The object code form of an Application may incorporate material from
-a header file that is part of the Library. You may convey such object
-code under terms of your choice, provided that, if the incorporated
-material is not limited to numerical parameters, data structure
-layouts and accessors, or small macros, inline functions and templates
-(ten or fewer lines in length), you do both of the following:
-
- a) Give prominent notice with each copy of the object code that the
- Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the object code with a copy of the GNU GPL and this license
- document.
-
- 4. Combined Works.
-
- You may convey a Combined Work under terms of your choice that,
-taken together, effectively do not restrict modification of the
-portions of the Library contained in the Combined Work and reverse
-engineering for debugging such modifications, if you also do each of
-the following:
-
- a) Give prominent notice with each copy of the Combined Work that
- the Library is used in it and that the Library and its use are
- covered by this License.
-
- b) Accompany the Combined Work with a copy of the GNU GPL and this license
- document.
-
- c) For a Combined Work that displays copyright notices during
- execution, include the copyright notice for the Library among
- these notices, as well as a reference directing the user to the
- copies of the GNU GPL and this license document.
-
- d) Do one of the following:
-
- 0) Convey the Minimal Corresponding Source under the terms of this
- License, and the Corresponding Application Code in a form
- suitable for, and under terms that permit, the user to
- recombine or relink the Application with a modified version of
- the Linked Version to produce a modified Combined Work, in the
- manner specified by section 6 of the GNU GPL for conveying
- Corresponding Source.
-
- 1) Use a suitable shared library mechanism for linking with the
- Library. A suitable mechanism is one that (a) uses at run time
- a copy of the Library already present on the user's computer
- system, and (b) will operate properly with a modified version
- of the Library that is interface-compatible with the Linked
- Version.
-
- e) Provide Installation Information, but only if you would otherwise
- be required to provide such information under section 6 of the
- GNU GPL, and only to the extent that such information is
- necessary to install and execute a modified version of the
- Combined Work produced by recombining or relinking the
- Application with a modified version of the Linked Version. (If
- you use option 4d0, the Installation Information must accompany
- the Minimal Corresponding Source and Corresponding Application
- Code. If you use option 4d1, you must provide the Installation
- Information in the manner specified by section 6 of the GNU GPL
- for conveying Corresponding Source.)
-
- 5. Combined Libraries.
-
- You may place library facilities that are a work based on the
-Library side by side in a single library together with other library
-facilities that are not Applications and are not covered by this
-License, and convey such a combined library under terms of your
-choice, if you do both of the following:
-
- a) Accompany the combined library with a copy of the same work based
- on the Library, uncombined with any other library facilities,
- conveyed under the terms of this License.
-
- b) Give prominent notice with the combined library that part of it
- is a work based on the Library, and explaining where to find the
- accompanying uncombined form of the same work.
-
- 6. Revised Versions of the GNU Lesser General Public License.
-
- The Free Software Foundation may publish revised and/or new versions
-of the GNU Lesser General Public License from time to time. Such new
-versions will be similar in spirit to the present version, but may
-differ in detail to address new problems or concerns.
-
- Each version is given a distinguishing version number. If the
-Library as you received it specifies that a certain numbered version
-of the GNU Lesser General Public License "or any later version"
-applies to it, you have the option of following the terms and
-conditions either of that published version or of any later version
-published by the Free Software Foundation. If the Library as you
-received it does not specify a version number of the GNU Lesser
-General Public License, you may choose any version of the GNU Lesser
-General Public License ever published by the Free Software Foundation.
-
- If the Library as you received it specifies that a proxy can decide
-whether future versions of the GNU Lesser General Public License shall
-apply, that proxy's public statement of acceptance of any version is
-permanent authorization for you to choose that version for the
-Library.
+LGPL-3.0-or-later
diff --git a/srfi/170/README.md b/srfi/170/README.md
index 9d09ba4..e062fd9 100644
--- a/srfi/170/README.md
+++ b/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)
diff --git a/srfi/170/VERSION b/srfi/170/VERSION
index 845639e..3a4036f 100644
--- a/srfi/170/VERSION
+++ b/srfi/170/VERSION
@@ -1 +1 @@
-0.1.4
+0.2.5
diff --git a/srfi/170/test.scm b/srfi/170/test.scm
index 5228fe7..d479c4a 100644
--- a/srfi/170/test.scm
+++ b/srfi/170/test.scm
@@ -1,12 +1,41 @@
+(import (scheme base)
+ (scheme write)
+ (scheme read)
+ (scheme char)
+ (scheme file)
+ (scheme process-context)
+ (retropikzel tap)
+ (foreign c)
+ (srfi 64)
+ (srfi 170))
+
(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 +174,7 @@
(display "file-info-directory? on file: ")
(write (file-info-directory? tmp-file-info))
(newline)
+|#
-(test-begin "srfi-170")
+
+(test-end "srfi-170")
diff --git a/test-headers.sps b/test-headers.sps
index 788aba2..c0fcc90 100644
--- a/test-headers.sps
+++ b/test-headers.sps
@@ -1,4 +1,4 @@
(import (rnrs)
(srfi :64)
(foreign c)
- (srfi SRFI))
+ (srfi :SRFI))
diff --git a/test.scm b/test.scm
new file mode 100644
index 0000000..d479c4a
--- /dev/null
+++ b/test.scm
@@ -0,0 +1,180 @@
+(import (scheme base)
+ (scheme write)
+ (scheme read)
+ (scheme char)
+ (scheme file)
+ (scheme process-context)
+ (retropikzel tap)
+ (foreign c)
+ (srfi 64)
+ (srfi 170))
+
+(test-begin "srfi-170")
+
+(write (posix-time))
+(newline)
+
+(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")
+(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"))
+(when (file-exists? tmp-file) (delete-file tmp-file))
+
+(with-output-to-file
+ tmp-file
+ (lambda ()
+ (display "Hello")
+ (newline)))
+
+(define tmp-dotfile (string-append tmp-dir "/.dot.txt"))
+(when (file-exists? tmp-dotfile) (delete-file tmp-dotfile))
+
+(with-output-to-file
+ tmp-dotfile
+ (lambda ()
+ (display "Dot")
+ (newline)))
+
+(define tmp-dir-info (file-info tmp-dir #f))
+(define tmp-file-info (file-info tmp-file #f))
+(define tmp-dotfile-info (file-info tmp-dotfile #f))
+
+(set-file-mode tmp-file 0755)
+
+
+(define dir1 (open-directory tmp-dir))
+(write (read-directory dir1))
+(newline)
+(write (read-directory dir1))
+(newline)
+(write (read-directory dir1))
+(newline)
+(close-directory dir1)
+
+(define dir2 (open-directory tmp-dir #t))
+(write (read-directory dir2))
+(newline)
+(write (read-directory dir2))
+(newline)
+(write (read-directory dir2))
+(newline)
+(close-directory dir2)
+
+(display "temp-file-prefix: ")
+(display (temp-file-prefix))
+(newline)
+
+(display "create-temp-file: ")
+(define tf1 (create-temp-file))
+(display tf1)
+(newline)
+
+(display "create-temp-file, with prefix lol: ")
+(define tf2 (create-temp-file "/tmp/lol"))
+(display tf2)
+(newline)
+
+(call-with-temporary-filename
+ (lambda (path)
+ (display "call-with-temporary-filename, path: ")
+ (display path)
+ (newline)))
+
+(display "Current directory: ")
+(display (current-directory))
+(newline)
+
+(set-current-directory! "/tmp")
+(display "Current directory: ")
+(display (current-directory))
+(newline)
+
+(display "pid: ")
+(display (pid))
+(newline)
+
+(display "uid: ")
+(display (user-uid))
+(newline)
+
+(display "gid: ")
+(display (user-gid))
+(newline)
+
+(display "euid: ")
+(display (user-effective-uid))
+(newline)
+
+(display "egid: ")
+(display (user-effective-gid))
+(newline)
+
+(display "user-supplementary-gids: ")
+(display (user-supplementary-gids))
+(newline)
+
+(display "user-info, uid 0: ")
+(display (user-info 0))
+(newline)
+
+(display "user-info, name root: ")
+(display (user-info "root"))
+(newline)
+
+(display "group-info: ")
+(display (group-info "root"))
+(newline)
+
+(display "set-environment-variable! lol=lel ")
+(newline)
+(set-environment-variable! "lol" "lel")
+
+;(display "get-environment-variable lol: ")
+;(display (get-environment-variable "lol"))
+;(newline)
+
+(define movefile "/tmp/test1.txt")
+(with-output-to-file
+ movefile
+ (lambda ()
+ (display "Hello")
+ (newline)))
+
+(rename-file movefile "/tmp/test2.txt")
+
+(display "File /tmp/test2.txt exists? ")
+(display (file-exists? "/tmp/test2.txt"))
+(newline)
+
+(display "file-info-directory? on dir: ")
+(write (file-info-directory? tmp-dir-info))
+(newline)
+
+(display "file-info-directory? on file: ")
+(write (file-info-directory? tmp-file-info))
+(newline)
+|#
+
+
+(test-end "srfi-170")