commit 85007b2d388e28c4d0c599ffb26384b8717aa23b Author: retropikzel Date: Tue Dec 2 07:44:41 2025 +0200 Making the infrastructure diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..5d1c239 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,46 @@ +ARG SCHEME=chibi +ARG IMAGE=${SCHEME}:head +FROM debian:trixie AS build +RUN apt-get update && apt-get install -y \ +git ca-certificates make gcc libffi-dev libffi-dev wget xz-utils libcurl4 +RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm +WORKDIR /build +RUN wget https://gitlab.com/-/project/6808260/uploads/094ce726ce3c6cf8c14560f1e31aaea0/akku-1.1.0.amd64-linux.tar.xz \ + && tar -xf akku-1.1.0.amd64-linux.tar.xz \ + && mv akku-1.1.0.amd64-linux akku +RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 +RUN git clone https://codeberg.org/retropikzel/compile-scheme.git --depth=1 +WORKDIR /build/chibi-scheme +RUN make +RUN make install +WORKDIR /build/compile-scheme +RUN make build-gauche +WORKDIR /build +RUN git clone https://codeberg.org/foreign-c/foreign-c.git --depth=2 + +ARG SCHEME=chibi +ARG IMAGE=${SCHEME}:head +FROM schemers/${IMAGE} +RUN apt-get update && apt-get install -y make gcc libffi-dev libcurl4 gauche +RUN mkdir ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm +COPY --from=build /build /build +ARG SCHEME=chibi +WORKDIR /build/compile-scheme +RUN make install +WORKDIR /build/chibi-scheme +RUN make install +WORKDIR /build/chibi-scheme +RUN make install +WORKDIR /build/akku +RUN bash install.sh +ENV PATH=/root/.local/bin:${PATH} +RUN akku update +WORKDIR /build/foreign-c +RUN if [ ! "${SCHEME}" = "racket" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(srfi 64)"; fi +RUN if [ ! "${SCHEME}" = "larceny" ]; then timeout 30 snow-chibi install --impls=${SCHEME} --always-yes "(foreign c)"; fi +RUN make SCHEME=${SCHEME} build install +WORKDIR /workdir +RUN cp -r /build/foreign-c/foreign . +COPY Makefile . +COPY srfi srfi/ + diff --git a/Jenkinsfile b/Jenkinsfile new file mode 100644 index 0000000..8e0e8d2 --- /dev/null +++ b/Jenkinsfile @@ -0,0 +1,70 @@ +pipeline { + agent { + docker { + label 'docker-x86_64' + image 'debian' + args '--user=root --privileged -v /var/run/docker.sock:/var/run/docker.sock' + } + } + + 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: '170', description: '') + } + + stages { + stage('Init') { + steps { + sh "apt-get update && apt-get install -y make docker.io git" + } + } + + stage('Tests') { + parallel { + stage('R6RS x86_64 Debian') { + steps { + script { + params.SRFIS.split().each { SRFI -> + params.R6RS_SCHEMES.split().each { SCHEME -> + def IMG="${SCHEME}:head" + stage("${SCHEME} - ${SRFI}") { + catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { + sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} test-r6rs-docker" + } + } + } + } + } + } + } + stage('R7RS x86_64 Debian') { + steps { + script { + params.SRFIS.split().each { SRFI -> + params.R7RS_SCHEMES.split().each { SCHEME -> + def IMG="${SCHEME}:head" + if("${SCHEME}" == "chicken") { + IMG="${SCHEME}:5" + } + stage("${SCHEME} - ${SRFI}") { + catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { + sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} test-r7rs-docker" + } + } + } + } + } + } + } + + } + } + + } +} diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..71385d6 --- /dev/null +++ b/Makefile @@ -0,0 +1,54 @@ +.SILENT: build install test test-docker clean +.PHONY: test-r6rs test-r7rs +SCHEME=chibi +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 + +PKG=srfi-${SRFI}-${VERSION}.tgz + +DOCKERIMG=${SCHEME}:head +ifeq "${SCHEME}" "chicken" +DOCKERIMG="chicken:5" +endif + +all: build + +build: srfi/${SRFI}/LICENSE srfi/${SRFI}/VERSION + echo "
$$(cat srfi/${SRFI}/README.md)
" > ${README} + snow-chibi package --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${SRFI_FILE} + +install: + snow-chibi install --impls=${SCHEME} ${SNOW_CHIBI_ARGS} ${PKG} + +uninstall: + -snow-chibi remove --impls=${SCHEME} ${PKG} + +test-r7rs: + echo "(import (scheme base) (scheme write) (scheme file) (scheme process-context) (srfi ${SRFI}) (srfi 64))" > test-r7rs.scm + cat srfi/${SRFI}/test.scm >> test-r7rs.scm + COMPILE_R7RS=${SCHEME} compile-scheme -I . -o test-r7rs test-r7rs.scm + printf "\n" | ./test-r7rs + +test-r7rs-docker: + docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} . + docker run -t foreign-c-srfi-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SRFI=${SRFI} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs" + +test-r6rs: + echo "(import (rnrs) (srfi ${SRFI}) (srfi :64))" > test-r6rs.sps + cat srfi/${SRFI}/test.scm >> test-r6rs.sps + akku install chez-srfi akku-r7rs "(foreign c)" + COMPILE_R7RS=${SCHEME} compile-scheme -I .akku/lib -o test-r6rs test-r6rs.sps + ./test-r6rs + +test-r6rs-docker: + docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-srfi-test-${SCHEME} . + docker run -t foreign-c-srfi-test-${SCHEME} sh -c "make SCHEME=${SCHEME} SRFI=${SRFI} test-r6rs" + +clean: + git clean -X -f diff --git a/srfi/170.scm b/srfi/170.scm new file mode 100644 index 0000000..71256dc --- /dev/null +++ b/srfi/170.scm @@ -0,0 +1,403 @@ +(define-c-library libc + '("stdlib.h" + "stdio.h" + "string.h" + "dirent.h" + "sys/stat.h" + "sys/types.h" + "unistd.h" + "pwd.h" + "grp.h" + "fcntl.h") + libc-name + '((additional-versions ("0" "6")))) + +(define-c-procedure c-perror libc 'perror 'void '(pointer)) +(define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int)) +(define-c-procedure c-rmdir libc 'rmdir 'int '(pointer)) +(define-c-procedure c-stat libc 'stat 'int '(pointer pointer)) +(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-readdir libc 'readdir 'pointer '(pointer)) +(define-c-procedure c-close libc 'close 'int '(int)) +(define-c-procedure c-closedir libc 'closedir 'int '(pointer)) +(define-c-procedure c-realpath libc 'realpath 'pointer '(pointer pointer)) +(define-c-procedure c-chmod libc 'chmod 'int '(pointer int)) +(define-c-procedure c-getpid libc 'getpid 'int '()) +(define-c-procedure c-time libc 'time 'int '(pointer)) +(define-c-procedure c-srand libc 'srand 'void '(int)) +(define-c-procedure c-rand libc 'rand 'int '()) +(define-c-procedure c-getcwd libc 'getcwd 'pointer '(pointer int)) +(define-c-procedure c-chdir libc 'chdir 'int '(pointer)) +(define-c-procedure c-getuid libc 'getuid 'int '()) +(define-c-procedure c-getgid libc 'getgid 'int '()) +(define-c-procedure c-geteuid libc 'geteuid 'int '()) +(define-c-procedure c-getegid libc 'getegid 'int '()) +(define-c-procedure c-getgroups libc 'getgroups 'int '(int pointer)) +(define-c-procedure c-getpwuid libc 'getpwuid 'pointer '(int)) +(define-c-procedure c-getpwnam libc 'getpwnam 'pointer '(pointer)) +(define-c-procedure c-getgrgid libc 'getgrgid 'pointer '(int)) +(define-c-procedure c-getgrnam libc 'getgrnam 'pointer '(pointer)) +(define-c-procedure c-setenv libc 'setenv 'int '(pointer pointer int)) +(define-c-procedure c-unsetenv libc 'unsetenv 'int '(pointer)) +(define-c-procedure c-rename libc 'rename 'int '(pointer pointer)) +(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 slash (cond-expand (windows "\\") (else "/"))) +(define randomized? #f) + +(define (random-to max) + (when (not randomized?) + (c-srand (c-time (make-c-null))) + (set! randomized? #t)) + (modulo (c-rand) max)) + +(define (random-string size) + (letrec + ((looper + (lambda (result integer) + (cond ((= (string-length result) size) result) + ((or (< integer 0) + (> integer 128)) + (looper result (random-to 128))) + (else + (let ((char (integer->char integer))) + (if (not (or (char-alphabetic? char) + (char-numeric? char))) + (looper result (c-rand)) + (looper (string-append result + (string (integer->char integer))) + (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?) + file-info? + (device file-info:device) + (inode file-info:inode) + (mode file-info:mode) + (nlinks file-info:nlinks) + (uid file-info:uid) + (gid file-info:gid) + (rdev file-info:rdev) + (size file-info:size) + (blksize file-info:blksize) + (blocks file-info:blocks) + (atime file-info:atime) + (mtime file-info:mtime) + (ctime file-info:ctime) + (fname/port file-info:fname/port) + (follow? file-info:follow?)) + +(define (file-info-directory? file-info) + (let ((handle (c-open (string->c-utf8 (file-info:fname/port file-info)) 2))) + (cond ((> handle 0) (c-close handle) #f) + (else #t)))) + +(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-utf8 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-utf8 error-message))) + (when (< result 0) + (c-perror error-pointer) + (c-free fname-pointer) + (c-free stat-pointer) + (c-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?))) + +(define create-directory + (lambda (fname . permission-bits) + (let* ((fname-pointer (string->c-utf8 fname)) + (mode (if (null? permission-bits) + #o775 + (string->number (string-append "#o" + (number->string (car permission-bits)))))) + (result (c-mkdir fname-pointer mode)) + (error-message "create-directory error") + (error-pointer (string->c-utf8 error-message))) + (c-free fname-pointer) + (when (< result 0) + (c-perror error-pointer) + (c-free error-pointer) + (error error-message))))) + +(define (create-hard-link old-fname new-fname) + (c-link (string->c-utf8 old-fname) + (string->c-utf8 new-fname))) + +(define (create-symlink old-fname new-fname) + (c-slink (string->c-utf8 old-fname) + (string->c-utf8 new-fname))) + +(define (rename-file old-fname new-fname) + (c-rename (string->c-utf8 old-fname) (string->c-utf8 new-fname))) + +(define (delete-directory fname) + (let* ((fname-pointer (string->c-utf8 fname)) + (result (c-rmdir fname-pointer)) + (error-message "delete-directory error") + (error-pointer (string->c-utf8 error-message))) + (c-free fname-pointer) + (when (< result 0) + (c-perror error-pointer) + (c-free error-pointer) + (error error-message)))) + +(define (set-file-owner fname uid gid) + (let ((fname-pointer (string->c-utf8 fname))) + (c-chown fname-pointer uid gid) + (c-free fname-pointer))) + +(define (pointer-string-read pointer offset) + (letrec* ((looper (lambda (c index result) + (if (char=? c #\null) + (list->string (reverse result)) + (looper (c-bytevector-char-ref pointer + (+ offset index)) + (+ index 1) + (cons c result)))))) + (looper (c-bytevector-char-ref pointer offset) 1 (list)))) + +; struct dirent d_name offset on linux +(define d-name-offset 19) + +(define directory-files + (lambda (dir . dotfiles?) + (letrec* ((include-dotfiles? (if (null? dotfiles?) #f (car dotfiles?))) + (path-pointer (string->c-utf8 dir)) + (directory-pointer (c-opendir path-pointer)) + (error-message "directory-files error") + (error-pointer (string->c-utf8 error-message)) + (dotfile? (lambda (name) (char=? (string-ref name 0) #\.))) + (looper (lambda (directory-entity files) + (if (c-null? directory-entity) + files + (let ((name (pointer-string-read directory-entity + d-name-offset))) + (looper (c-readdir directory-pointer) + (cond ((string=? name ".") files) + ((string=? name "..") files) + ((and include-dotfiles? + (dotfile? name)) + (cons name files)) + ((not (dotfile? name)) + (cons name files)) + (else files)))))))) + (when (c-null? directory-pointer) + (c-perror error-pointer) + ;(c-free error-pointer) + ;(c-free directory) + ;(c-free path-pointer) + (error error-message)) + (let ((files (looper (c-readdir directory-pointer) (list)))) + ;(c-free error-pointer) + ;(c-free directory-pointer) + ;(c-free path-pointer) + (c-closedir directory-pointer) + files)))) + +(define real-path + (lambda (path) + (let* ((path-pointer (string->c-utf8 path)) + (real-path-pointer (c-realpath path-pointer (make-c-null))) + (real-path (string-copy (c-utf8->string real-path-pointer)))) + (c-free path-pointer) + (c-free real-path-pointer) + real-path))) + +(define (set-file-mode path mode) + (c-chmod (string->c-utf8 path) + (string->number (string-append "#o" (number->string mode))))) + +(define-record-type + (make-directory handle dot-files?) + directory? + (handle directory:handle) + (dot-files? directory:dot-files?)) + +(define (open-directory path . dot-files?) + (make-directory (c-opendir (string->c-utf8 path)) + (if (null? dot-files?) + #f + (car dot-files?)))) + +(define (read-directory directory-object) + (let ((directory-entity (c-readdir (directory:handle directory-object)))) + (if (c-null? directory-entity) + (eof-object) + (let ((name (pointer-string-read directory-entity d-name-offset))) + (cond ((or (string=? name ".") + (string=? name "..")) + (read-directory directory-object)) + ((and (directory:dot-files? directory-object) + (char=? (string-ref name 0) #\.)) + name) + ((char=? (string-ref name 0) #\.) + (read-directory directory-object)) + (else name)))))) + +(define (close-directory directory-object) + (c-closedir (directory:handle directory-object))) + +(define temp-file-prefix + (make-parameter + (if (get-environment-variable "TMPDIR") + (string-append (get-environment-variable "TMPDIR") + slash + (number->string (c-getpid))) + (string-append + (cond-expand (windows (get-environment-variable "TMP")) (else "/tmp")) + slash + (number->string (c-getpid)))))) + +(define create-temp-file + (lambda prefix + (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))) + (path (string-append real-prefix "-" (random-string 6)))) + (if (file-exists? path) + (create-temp-file real-prefix) + (begin + (with-output-to-file path (lambda () (display ""))) + (set-file-mode path 600) + path))))) + +(define (call-with-temporary-filename maker . prefix) + (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))) + (path (string-append real-prefix "-" (random-string 6)))) + (apply maker (list path)))) + +(define (current-directory) + (let* ((path-pointer (make-c-bytevector 1024)) + (path (begin + (c-getcwd path-pointer 1024) + (string-copy (c-utf8->string path-pointer))))) + (c-free path-pointer) + path)) + +(define (set-current-directory! path) + (c-chdir (string->c-utf8 path))) + +(define (pid) + (c-getpid)) + +(define (user-uid) + (c-getuid)) + +(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) + (if (>= count max-count) + result + (groups-loop max-count + (+ count 1) + groups-pointer + (append result + (list (c-bytevector-sint-ref groups-pointer + (* (c-type-size 'int) count) + (native-endianness) + (c-type-size 'int))))))) + +(define (user-supplementary-gids) + (let* ((group-count (c-getgroups 0 (make-c-null))) + (groups (make-c-bytevector (* (c-type-size 'int) group-count)))) + (c-getgroups group-count groups) + (groups-loop group-count 0 groups (list)))) + +(define-record-type + (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)) + +(define (user-info uid/name) + (let ((password-struct (if (number? uid/name) + (c-getpwuid uid/name) + (c-getpwnam (string->c-utf8 uid/name))))) + (make-user-info (c-utf8->string (c-bytevector-pointer-ref password-struct + 0)) + (c-bytevector-sint-ref password-struct + (* (c-type-size 'pointer) 2) + (native-endianness) + (c-type-size 'int)) + (c-bytevector-sint-ref password-struct + (+ (* (c-type-size 'pointer) 2) + (c-type-size 'int)) + (native-endianness) + (c-type-size 'int)) + (c-utf8->string (c-bytevector-pointer-ref password-struct + (+ (* (c-type-size 'pointer) 3) + (* (c-type-size 'int) 2)))) + (c-utf8->string (c-bytevector-pointer-ref password-struct + (+ (* (c-type-size 'pointer) 4) + (* (c-type-size 'int) 2)))) + (c-utf8->string (c-bytevector-pointer-ref password-struct + (+ (* (c-type-size 'pointer) 2) + (* (c-type-size 'int) 2))))))) + + +(define-record-type + (make-group-info name gid) + group-info? + (name group-info:name) + (gid group-info:gid)) + +(define (group-info gid/name) + (let ((group-struct (if (number? gid/name) + (c-getgrgid gid/name) + (c-getgrnam (string->c-utf8 gid/name))))) + (make-group-info + (c-utf8->string (c-bytevector-pointer-ref group-struct 0)) + (c-bytevector-sint-ref group-struct + (* (c-type-size 'pointer) 2) + (native-endianness) + (c-type-size 'int))))) + +(define (set-environment-variable! name value) + (c-setenv (string->c-utf8 name) (string->c-utf8 value) 1)) + +(define (delete-environment-variable! name) + (c-unsetenv (string->c-utf8 name))) diff --git a/srfi/170.sld b/srfi/170.sld new file mode 100644 index 0000000..98b85c9 --- /dev/null +++ b/srfi/170.sld @@ -0,0 +1,86 @@ +(define-library + (srfi 170) + (import (scheme base) + (scheme char) + (scheme write) + (scheme file) + (scheme process-context) + (foreign c)) + (export ;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? + ) + (include "170.scm")) diff --git a/srfi/170/LICENSE b/srfi/170/LICENSE new file mode 100644 index 0000000..0a04128 --- /dev/null +++ b/srfi/170/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. diff --git a/srfi/170/README.md b/srfi/170/README.md new file mode 100644 index 0000000..808a6eb --- /dev/null +++ b/srfi/170/README.md @@ -0,0 +1,83 @@ +Implementation of [SRFI 170](https://srfi.schemers.org/srfi-170/srfi-170.html) +POSIX API using [(foreign c)](https://git.sr.ht/~retropikzel/foreign-c). + +Currently only supports Linux. + +Uncommented things here are implemented. + + ;;;;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? diff --git a/srfi/170/VERSION b/srfi/170/VERSION new file mode 100644 index 0000000..17e51c3 --- /dev/null +++ b/srfi/170/VERSION @@ -0,0 +1 @@ +0.1.1 diff --git a/srfi/170/test.scm b/srfi/170/test.scm new file mode 100644 index 0000000..770571c --- /dev/null +++ b/srfi/170/test.scm @@ -0,0 +1,146 @@ + +(display (real-path "Makefile")) +(newline) + +(exit 0) + +(define tmp-dir "/tmp/foreign-c-srfi-170") +(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) diff --git a/srfi/srfi-170.scm b/srfi/srfi-170.scm new file mode 100644 index 0000000..ec104aa --- /dev/null +++ b/srfi/srfi-170.scm @@ -0,0 +1,87 @@ +;; This file exists for guile compability +(define-library + (srfi 170) + (import (scheme base) + (scheme char) + (scheme write) + (scheme file) + (foreign c) + (scheme process-context)) + (export ;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? + ) + (include "170.scm"))