Do not test with Guile or mit-scheme on Jenkins

This commit is contained in:
retropikzel 2026-07-18 20:18:48 +03:00
parent 92ca74ad0c
commit 3e69388c17
4 changed files with 121 additions and 120 deletions

2
Jenkinsfile vendored
View File

@ -28,7 +28,7 @@ pipeline {
environment { environment {
R6RS_SCHEMES='capyscheme chezscheme guile ikarus ironscheme loko mosh racket sagittarius ypsilon' R6RS_SCHEMES='capyscheme chezscheme guile ikarus ironscheme loko mosh racket sagittarius ypsilon'
R7RS_SCHEMES='capyscheme chibi chicken cyclone foment gauche gambit guile kawa loko meevax mit-scheme mosh racket sagittarius skint stklos tr7 ypsilon' R7RS_SCHEMES='capyscheme chibi chicken cyclone foment gauche gambit kawa loko meevax mosh racket sagittarius skint stklos tr7 ypsilon'
LIBRARIES='tap ctrf mouth string url-encoding leb128 hardware-info' LIBRARIES='tap ctrf mouth string url-encoding leb128 hardware-info'
} }

View File

@ -63,7 +63,7 @@ test: testfiles
cd ${tmpdir} && ./test-program cd ${tmpdir} && ./test-program
test-docker: testfiles test-docker: testfiles
SNOW_PACKAGES="srfi.64 ${PKG}" \ SNOW_PACKAGES="srfi.64 srfi.180 ${PKG}" \
APT_PACKAGES="libcurl4-openssl-dev" \ APT_PACKAGES="libcurl4-openssl-dev" \
AKKU_PACKAGES="akku-r7rs" \ AKKU_PACKAGES="akku-r7rs" \
DOCKER_TAG=${DOCKER_TAG} \ DOCKER_TAG=${DOCKER_TAG} \

View File

@ -1,123 +1,124 @@
(define ctrf-runner (define-syntax ctrf-runner
(lambda () (syntax-rules ()
(let ((any->string ((_)
(lambda (any) (let ((any->string
(let ((port (open-output-string))) (lambda (any)
(display any port) (let ((port (open-output-string)))
(newline port) (display any port)
(get-output-string port)))) (newline port)
(runner (test-runner-null)) (get-output-string port))))
(tests (vector)) (runner (test-runner-null))
(failed-tests (vector)) (tests (vector))
(current-test-start-time 0) (failed-tests (vector))
(current-test-groups (vector)) (current-test-start-time 0)
(current-test-group-count 0) (current-test-groups (vector))
(first-group-name #f)) (current-test-group-count 0)
(first-group-name #f))
(test-runner-on-group-begin! (test-runner-on-group-begin!
runner runner
(lambda (runner suite-name count) (lambda (runner suite-name count)
(set! current-test-group-count 0) (set! current-test-group-count 0)
(when (not first-group-name) (set! first-group-name suite-name)) (when (not first-group-name) (set! first-group-name suite-name))
(set! current-test-groups (set! current-test-groups
(vector-append current-test-groups (vector suite-name))))) (vector-append current-test-groups (vector suite-name)))))
(test-runner-on-group-end! (test-runner-on-group-end!
runner runner
(lambda (runner) (lambda (runner)
(set! current-test-groups (set! current-test-groups
(list->vector (list->vector
(reverse (reverse
(list-tail (list-tail
(reverse (vector->list current-test-groups)) (reverse (vector->list current-test-groups))
1)))))) 1))))))
(test-runner-on-test-begin! (test-runner-on-test-begin!
runner runner
(lambda (runner) (lambda (runner)
(set! current-test-group-count (+ current-test-group-count 1)) (set! current-test-group-count (+ current-test-group-count 1))
(set! current-test-start-time (time-s)))) (set! current-test-start-time (time-s))))
(test-runner-on-test-end! (test-runner-on-test-end!
runner runner
(lambda (runner) (lambda (runner)
(let* ((name (test-runner-test-name runner)) (let* ((name (test-runner-test-name runner))
(result (test-result-kind runner)) (result (test-result-kind runner))
(status (cond ((equal? result 'pass) "passed") (status (cond ((equal? result 'pass) "passed")
((equal? result 'xpass) "passed") ((equal? result 'xpass) "passed")
((equal? result 'fail) "failed") ((equal? result 'fail) "failed")
((equal? result 'xfail) "failed") ((equal? result 'xfail) "failed")
((equal? result 'skipped) "skipped") ((equal? result 'skipped) "skipped")
(else "other"))) (else "other")))
(duration (- (time-s) current-test-start-time)) (duration (- (time-s) current-test-start-time))
(result-ref (result-ref
(lambda (runner key) (lambda (runner key)
(let ((value (test-result-ref runner key))) (let ((value (test-result-ref runner key)))
(if value (any->string value) ""))))) (if value (any->string value) "")))))
(let* ((suite (car (reverse (vector->list current-test-groups)))) (let* ((suite (car (reverse (vector->list current-test-groups))))
(test `((name . ,name) (test `((name . ,name)
(status . ,status) (status . ,status)
(duration . ,duration) (duration . ,duration)
(suite . ,suite) (suite . ,suite)
(extra . ((source-file . ,(result-ref runner 'source-file)) (extra . ((source-file . ,(result-ref runner 'source-file))
(source-line . ,(result-ref runner 'source-line)) (source-line . ,(result-ref runner 'source-line))
(source-form . ,(result-ref runner 'source-form)) (source-form . ,(result-ref runner 'source-form))
(count . ,current-test-group-count) (count . ,current-test-group-count)
(expected-value . ,(result-ref runner 'expected-value)) (expected-value . ,(result-ref runner 'expected-value))
(actual-value . ,(result-ref runner 'actual-value)) (actual-value . ,(result-ref runner 'actual-value))
(expected-error . ,(result-ref runner 'expected-error)) (expected-error . ,(result-ref runner 'expected-error))
(actual-error . ,(result-ref runner 'actual-error))))))) (actual-error . ,(result-ref runner 'actual-error)))))))
(when (or (equal? result 'fail) (when (or (equal? result 'fail)
(equal? result 'xfail)) (equal? result 'xfail))
(let ((failed (cons `(suite . ,suite) test))) (let ((failed (cons `(suite . ,suite) test)))
(display "FAIL " (current-error-port)) (display "FAIL " (current-error-port))
(json-write failed (current-error-port)) (json-write failed (current-error-port))
(newline (current-error-port)) (newline (current-error-port))
(set! failed-tests (vector-append failed-tests (vector failed))))) (set! failed-tests (vector-append failed-tests (vector failed)))))
(set! tests (vector-append tests (vector test))))))) (set! tests (vector-append tests (vector test)))))))
(test-runner-on-final! (test-runner-on-final!
runner runner
(lambda (runner) (lambda (runner)
(let* (let*
((pass (test-runner-pass-count runner)) ((pass (test-runner-pass-count runner))
(xpass (test-runner-xpass-count runner)) (xpass (test-runner-xpass-count runner))
(fail (test-runner-fail-count runner)) (fail (test-runner-fail-count runner))
(xfail (test-runner-xfail-count runner)) (xfail (test-runner-xfail-count runner))
(skipped (test-runner-skip-count runner)) (skipped (test-runner-skip-count runner))
(tool `((name . "(retropikzel ctrf)") (tool `((name . "(retropikzel ctrf)")
(version . "1.0.0"))) (version . "1.0.0")))
(summary `((tests . ,(+ pass xpass fail xfail)) (summary `((tests . ,(+ pass xpass fail xfail))
(passed . ,(+ pass xpass)) (passed . ,(+ pass xpass))
(failed . ,(+ fail xfail)) (failed . ,(+ fail xfail))
(pending . 0) (pending . 0)
(skipped . ,skipped) (skipped . ,skipped)
(other . 0))) (other . 0)))
(results `((tool . ,tool) (results `((tool . ,tool)
(summary . ,summary) (summary . ,summary)
(tests . ,tests))) (tests . ,tests)))
(env `((appName . ,implementation-name) (env `((appName . ,implementation-name)
(osPlatform . ,operation-system))) (osPlatform . ,operation-system)))
(output `((reportFormat . "CTRF") (output `((reportFormat . "CTRF")
(specVersion . "0.0.0") (specVersion . "0.0.0")
(results . ,results) (results . ,results)
(generatedBy . "(retropikzel ctrf)") (generatedBy . "(retropikzel ctrf)")
(environment . ,env))) (environment . ,env)))
(output-file (string-append implementation-name (output-file (string-append implementation-name
"-" "-"
first-group-name first-group-name
".ctrf.json")) ".ctrf.json"))
(short-output `((scheme . ,implementation-name) (short-output `((scheme . ,implementation-name)
(summary . ,summary) (summary . ,summary)
(full . ,output-file)))) (full . ,output-file))))
(when (file-exists? output-file) (delete-file output-file)) (when (file-exists? output-file) (delete-file output-file))
(with-output-to-file (with-output-to-file
output-file output-file
(lambda () (lambda ()
(json-write output (current-output-port)))) (json-write output (current-output-port))))
(json-write short-output (current-output-port)) (json-write short-output (current-output-port))
(newline (current-output-port)) (newline (current-output-port))
;(exit (+ fail xfail)) ;(exit (+ fail xfail))
))) )))
runner))) runner))))

View File

@ -1 +1 @@
1.2.1 1.2.2