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')) buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
} }
parameters { environment {
string(name: 'R7RS_SCHEMES', defaultValue: 'chibi chicken gauche guile kawa mosh racket sagittarius stklos ypsilon', description: '') R7RS_SCHEMES="capyscheme chibi chicken gauche kawa mosh racket sagittarius stklos ypsilon"
string(name: 'R6RS_SCHEMES', defaultValue: 'chezscheme guile ikarus ironscheme mosh racket sagittarius ypsilon', description: '') R6RS_SCHEMES="chezscheme guile ikarus ironscheme mosh racket sagittarius ypsilon"
string(name: 'SRFIS', defaultValue: '106 170', description: '') SRFIS="170"
} }
stages { stages {
stage('Tests') { stage('x86_64 Debian') {
stage('R6RS x86_64 Debian') { steps {
steps { script {
script { env.SRFIS.split().each { SRFI ->
params.SRFIS.split().each { SRFI -> env.R6RS_SCHEMES.split().each { SCHEME ->
params.R6RS_SCHEMES.split().each { SCHEME -> stage("${SCHEME} ${SRFI}") {
stage("${SCHEME} - ${SRFI}") { catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { sh "make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker"
sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker"
}
} }
} }
} }
} }
} }
} }
stage('R7RS x86_64 Debian') { }
steps { stage('R7RS x86_64 Debian') {
script { steps {
params.SRFIS.split().each { SRFI -> script {
params.R7RS_SCHEMES.split().each { SCHEME -> env.SRFIS.split().each { SRFI ->
stage("${SCHEME} - ${SRFI}") { env.R7RS_SCHEMES.split().each { SCHEME ->
catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') { stage("${SCHEME} ${SRFI}") {
sh "timeout 600 make SCHEME=${SCHEME} SRFI=${SRFI} RNRS=r6rs run-test-docker" 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 mkdir -p .tmp
cp ${PKG} .tmp cp ${PKG} .tmp
cp -r srfi .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} cat ${TESTFILE} >> run-test.${SFX}
if [ "${RNRS}" = "r6rs" ]; then if [ -d ../foreign-c ]; then cp -r ../foreign-c/foreign .tmp/; fi; fi if [ "${RNRS}" = "r6rs" ]; \
then if [ -d ../foreign-c ]; \
then cp -r ../foreign-c/foreign .tmp/; \
fi; \
fi
test: testfiles package test: testfiles package
cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX} cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX}
@ -52,7 +57,7 @@ test: testfiles package
test-docker: testfiles package test-docker: testfiles package
cd .tmp && \ cd .tmp && \
DOCKER_TAG=${DOCKER_TAG} \ 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" \ APT_PACKAGES="libcurl4-openssl-dev" \
COMPILE_R7RS=${SCHEME} \ COMPILE_R7RS=${SCHEME} \
TEST_R7RS_DEBUG=1 \ TEST_R7RS_DEBUG=1 \

31
srfi/170.scm
View File

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

17
srfi/170/test.scm
View File

@ -1,12 +1,12 @@
(test-begin "srfi-170") (test-begin "srfi-170")
;(display (real-path "Makefile"))
;(newline)
;(exit 0)
(define tmp-dir "/tmp/foreign-c-srfi-170") (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) (create-directory tmp-dir)
(define tmp-file (string-append tmp-dir "/test.txt")) (define tmp-file (string-append tmp-dir "/test.txt"))
@ -146,4 +146,7 @@
(write (file-info-directory? tmp-file-info)) (write (file-info-directory? tmp-file-info))
(newline) (newline)
(test-begin "srfi-170") (write (posix-time))
(newline)
(test-end "srfi-170")