Retropikzel
/
foreign-c-srfis
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Improve testing of SRFI-170. Add posix-time

This commit is contained in:
retropikzel 2026-06-27 14:50:40 +03:00
parent 54f85917b5
commit f8a7458b99
4 changed files with 50 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
Jenkinsfile vendored
View File

@ -12,38 +12,36 @@ pipeline {
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('x86_64 Debian') {
steps {
script {
env.SRFIS.split().each { SRFI ->
env.R6RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME} ${SRFI}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-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 x86_64 Debian') {
steps {
script {
env.SRFIS.split().each { SRFI ->
env.R7RS_SCHEMES.split().each { SCHEME ->
stage("${SCHEME} ${SRFI}") {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
sh "make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker"
}
}
}

11
Makefile
View File

@ -41,9 +41,14 @@ testfiles:
mkdir -p .tmp
cp ${PKG} .tmp
cp -r srfi .tmp/
cat test-headers.${SFX} ${TESTFILE} | sed 's/SRFI/${SRFI}/' > .tmp/test.${SFX}
cat test-headers.${SFX} ${TESTFILE} \
| sed 's/SRFI/${SRFI}/' > .tmp/test.${SFX}
cat ${TESTFILE} >> run-test.${SFX}
if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign .tmp/; fi; fi
if [ "${RNRS}" = "r6rs" ]; \
then if [ -d ../foreign-c ]; \
then cp -r ../foreign-c/foreign .tmp/; \
fi; \
fi
test: testfiles package
cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX}
@ -52,7 +57,7 @@ test: testfiles package
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}" \
SNOW_PACKAGES="srfi.64 ${PKG}" \
APT_PACKAGES="libcurl4-openssl-dev" \
COMPILE_R7RS=${SCHEME} \
TEST_R7RS_DEBUG=1 \

31
srfi/170.scm
View File

@ -206,14 +206,14 @@
(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)))
(result (c-rmdir fname-pointer)))
(c-bytevector-free fname-pointer)
(when (< result 0)
(c-perror error-pointer)
(c-bytevector-free error-pointer)
(error error-message))))
(let* ((error-message "delete-directory error")
(error-pointer (string->c-bytevector error-message)))
(c-perror error-pointer)
(c-bytevector-free error-pointer)
(error error-message)))))
(define (set-file-owner fname uid gid)
(let ((fname-pointer (string->c-bytevector fname)))
@ -468,17 +468,8 @@
(c-bytevector-free error-pointer)
(error error-message)))
(else
(let* ((tv-sec (c-bytevector-ref timespec tv_sec-type 0))
(tv-nsec (c-bytevector-ref timespec
tv_nsec-type
(c-type-size tv_sec-type)))
(time (make-time time-utc tv-sec tv-nsec)))
(display "HERE: tv-sec ")
(write tv-sec)
(newline)
(display "HERE: tv-nsec ")
(write tv-nsec)
(newline)
time
)))
))
(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))))))

17
srfi/170/test.scm
View File

@ -1,12 +1,12 @@
(test-begin "srfi-170")
;(display (real-path "Makefile"))
;(newline)
;(exit 0)
(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"))
@ -146,4 +146,7 @@
(write (file-info-directory? tmp-file-info))
(newline)
(test-begin "srfi-170")
(write (posix-time))
(newline)
(test-end "srfi-170")