Further rewrite of testrunner.

Move many of the atomic procedures into proper libraries.

10 files changed, 375 insertions, 146 deletions

diff --git a/Makefile b/Makefile
index a1809876..2d21588f 100644
--- a/Makefile
+++ b/Makefile
@@ -102,7 +102,7 @@ install: all calp-release
 unit-test-deps: calp $(GO_UNIT_TESTS) $(GO_FILES) $(TEST_FILES)
 
 $(COV_FILE): cpucount unit-test-deps
-	./testrunner.scm --threads $(shell ./cpucount) --coverage $@
+	./testrunner.scm --threads $(shell ./cpucount) --coverage $@ --coverage-supplement tests/unit/coverage-supplement.scm
 
 unit-test-with-cov: $(COV_FILE)
 
diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm
index 384afd4b..38df0ee1 100644
--- a/module/hnh/test/testrunner.scm
+++ b/module/hnh/test/testrunner.scm
@@ -1,8 +1,11 @@
 (define-module (hnh test testrunner)
   :use-module (srfi srfi-64)
   :use-module (hnh test util)
+  :use-module (hnh util type)
+  :use-module (hnh util atomic-queue)
   :use-module (ice-9 pretty-print)
   :use-module (ice-9 format)
+  :use-module (ice-9 curried-definitions)
   :export (verbose? construct-test-runner)
   )
 
@@ -21,97 +24,124 @@
               width: (- 79 (string-length indent)))))
      (string-append indent prefix-1))))
 
+;;; Return a "name" for the test.
+;;; If the test was explicitly named, than that name will be used.
+;;; Otherwise a string describing the expected value will be returned.
+(define (test-runner-test-name/description runner)
+  (cond ((test-runner-test-name runner)
+         (negate string-null?) => identity)
+        ((test-result-ref runner 'expected-value)
+         => (lambda (p) (with-output-to-string
+                     (lambda ()
+                       (display (bold "[SOURCE]: "))
+                       (truncated-print p width: 60)))))))
 
-(define (construct-test-runner)
+
+(define (test-runner-describe-error runner depth)
+  (cond ((test-result-ref runner 'actual-error)
+         => (lambda (err)
+              (if (and (list? err)
+                       (= 5 (length err)))
+                  (let ((err (list-ref err 0))
+                        (proc (list-ref err 1))
+                        (fmt (list-ref err 2))
+                        (args (list-ref err 3)))
+                    (format #t "~a~a in ~a: ~?~%"
+                            (make-indent (1+ depth))
+                            err proc fmt args))
+                  (format #t "~aError: ~s~%" (make-indent (1+ depth)) err))))
+        (else
+         (let ((unknown-expected (gensym))
+               (unknown-actual (gensym)))
+           (let ((expected (test-result-ref runner 'expected-value unknown-expected))
+                 (actual (test-result-ref runner 'actual-value unknown-actual)))
+             (let ((indent (make-indent (1+ depth))))
+               (if (eq? expected unknown-expected)
+                   (format #t "~aAssertion failed~%" indent)
+                   (begin
+                     (display (pp expected indent "Expected: "))
+                     (display (pp actual indent "Received: "))
+                     (let ((d (diff (pp expected "" "")
+                                    (pp actual "" ""))))
+                       (display
+                        (string-join
+                         (map (lambda (line) (string-append indent "|" line))
+                              (string-split d #\newline))
+                         "\n" 'suffix))))))))))
+
+  (format #t "~aNear ~a:~a~%"
+          (make-indent (1+ depth))
+          (test-result-ref runner 'source-file)
+          (test-result-ref runner 'source-line))
+  (pretty-print (test-result-ref runner 'source-form)
+                (current-output-port)
+                per-line-prefix: (string-append (make-indent (1+ depth)) "> ")))
+
+(define ((construct-test-runner print err-queue))
+  (typecheck err-queue atomic-queue?)
   (define runner (test-runner-null))
+  ;; TODO wouldn't `depth` need to be atomic to work?
   (define depth 0)
-  ;; end of individual test case
+
   (test-runner-on-test-begin! runner
     (lambda (runner)
+      ;; This should be thread local, TODO test that
       (test-runner-aux-value! runner (transform-time-of-day (gettimeofday)))))
+
   (test-runner-on-test-end! runner
     (lambda (runner)
       (when (verbose?) (display (make-indent depth)))
-      (case (test-result-kind runner)
-        ((pass)  (display (green "X")))
-        ((fail)  (display (red "E")))
-        ((xpass) (display (yellow "X")))
-        ((xfail) (display (yellow "E")))
-        ((skip)  (display (yellow "-"))))
-      (when (or (verbose?) (eq? 'fail (test-result-kind)))
-        (format #t " ~a~%"
-                (cond ((test-runner-test-name runner)
-                       (negate string-null?) => identity)
-                      ((test-result-ref runner 'expected-value)
-                       => (lambda (p) (with-output-to-string
-                                   (lambda ()
-                                     (display (bold "[SOURCE]: "))
-                                     (truncated-print p width: 60))))))))
+      (display
+       (case (test-result-kind runner)
+         ((pass)  (green "X"))
+         ((fail)  (red "E"))
+         ((xpass) (red "X"))
+         ((xfail) (yellow "E"))
+         ((skip)  (yellow "-"))))
+
+      (when (or (verbose?) #;(eq? 'fail (test-result-kind)))
+        (format #t " ~a~%" (test-runner-test-name/description runner)))
+
       (when (eq? 'fail (test-result-kind))
-        (cond ((test-result-ref runner 'actual-error)
-               => (lambda (err)
-                    (if (and (list? err)
-                             (= 5 (length err)))
-                        (let ((err (list-ref err 0))
-                              (proc (list-ref err 1))
-                              (fmt (list-ref err 2))
-                              (args (list-ref err 3)))
-                         (format #t "~a~a in ~a: ~?~%"
-                                 (make-indent (1+ depth))
-                                 err proc fmt args))
-                        (format #t "~aError: ~s~%" (make-indent (1+ depth)) err))))
-              (else
-               (let ((unknown-expected (gensym))
-                     (unknown-actual (gensym)))
-                 (let ((expected (test-result-ref runner 'expected-value unknown-expected))
-                       (actual (test-result-ref runner 'actual-value unknown-actual)))
-                   (let ((indent (make-indent (1+ depth))))
-                     (if (eq? expected unknown-expected)
-                         (format #t "~aAssertion failed~%" indent)
-                         (begin
-                           (display (pp expected indent "Expected: "))
-                           (display (pp actual indent "Received: "))
-                           (let ((d (diff (pp expected "" "")
-                                          (pp actual "" ""))))
-                             (display
-                              (string-join
-                               (map (lambda (line) (string-append indent "|" line))
-                                    (string-split d #\newline))
-                               "\n" 'suffix))))))))))
-        (format #t "~aNear ~a:~a~%"
-                (make-indent (1+ depth))
-                (test-result-ref runner 'source-file)
-                (test-result-ref runner 'source-line))
-        (pretty-print (test-result-ref runner 'source-form)
-                      (current-output-port)
-                      per-line-prefix: (string-append (make-indent (1+ depth)) "> ")
-                      ))
+        (enqueue!
+         (with-output-to-string
+           (lambda ()
+             (display
+              (red (format #f "Test failed: ~a~%"
+                           (test-runner-test-name/description runner))))
+             (test-runner-describe-error runner 0)))
+         err-queue))
 
       (let ((start (test-runner-aux-value runner))
             (end (transform-time-of-day (gettimeofday))))
         (when (< (µs 1) (- end start))
-          (format #t "~%Slow test: ~s, took ~a~%"
-                  (test-runner-test-name runner)
-                  (exact->inexact (/ (- end start) (µs 1)))
-                  )))))
+          (enqueue!
+           (format #f "~%Slow test: ~s, took ~a~%"
+                   (test-runner-test-name/description runner)
+                   (exact->inexact (/ (- end start) (µs 1))))
+           err-queue)))
+
+      ))
 
   ;; on start of group
   (test-runner-on-group-begin! runner
     ;; count is number of #f
     (lambda (runner name count)
-      (if (<= depth 1)
+      (if (<= depth 0)
           (format #t "~a ~a ~a~%"
                   (make-string 10 #\=)
                   name
                   (make-string 10 #\=))
           (when (verbose?)
-           (format #t "~a~a~%" (make-string (* depth 2) #\space) name)))
+            (format #t "~a~a~%" (make-string (* depth 2) #\space) name)))
       (set! depth (1+ depth))))
+
   (test-runner-on-group-end! runner
     (lambda (runner)
       (set! depth (1- depth))
       (when (<= depth 1)
         (newline))))
+
   ;; after everything else is done
   (test-runner-on-final! runner
     (lambda (runner)
diff --git a/module/hnh/util/atomic-queue.scm b/module/hnh/util/atomic-queue.scm
new file mode 100644
index 00000000..2ab0c2ef
--- /dev/null
+++ b/module/hnh/util/atomic-queue.scm
@@ -0,0 +1,49 @@
+(define-module (hnh util atomic-queue)
+  :use-module (srfi srfi-18)            ; Threading
+  :use-module (rnrs records syntactic)
+  :use-module (rnrs exceptions)
+  ;; :use-module (rnrs mutable-pair)
+  :use-module (hnh util atomic)
+  :use-module (hnh util type)
+  :use-module ((hnh util) :select (begin1))
+  :export (atomic-queue
+           atomic-queue?
+           queue-peek queue->list
+           enqueue! dequeue!))
+
+
+
+;;; Items are added at the back, and poped from the front
+
+(define-record-type (queue %atomic-queue atomic-queue?)
+  (fields front
+          (mutable back)
+          front-mutex back-mutex)
+  (sealed #t)
+  (opaque #t))
+
+(define (atomic-queue)
+  (let ((p (list 'FRONT)))
+    (%atomic-queue p p (make-mutex) (make-mutex))))
+
+(define (enqueue! value q)
+  (typecheck q atomic-queue?)
+  (with-mutex (queue-back-mutex q)
+    (set-cdr! (queue-back q) (list value))
+    (queue-back-set! q (cdr (queue-back q)))))
+
+(define (queue-peek q)
+  (typecheck q atomic-queue?)
+  (cadr (queue-front q)))
+
+(define (dequeue! q)
+  (typecheck q atomic-queue?)
+  (with-mutex (queue-front-mutex q)
+    (guard (_ (else #f))
+      (begin1 (queue-peek q)
+              (set-cdr! (queue-front q)
+                        (cddr (queue-front q)))))))
+
+(define (queue->list q)
+  (typecheck q atomic-queue?)
+  (cdr (queue-front q)))
diff --git a/module/hnh/util/atomic-stack.scm b/module/hnh/util/atomic-stack.scm
new file mode 100644
index 00000000..6b17724d
--- /dev/null
+++ b/module/hnh/util/atomic-stack.scm
@@ -0,0 +1,43 @@
+(define-module (hnh util atomic-stack)
+  :use-module (srfi srfi-18)            ; Threading
+  :use-module (rnrs records syntactic)
+  :use-module (rnrs exceptions)
+  :use-module (hnh util atomic)
+  :use-module ((hnh util type) :select (typecheck))
+  :use-module ((hnh util) :select (begin1))
+  :export (atomic-stack
+           atomic-stack?
+           stack-peek stack->list
+           push! pop!))
+
+(define-record-type (stack %atomic-stack atomic-stack?)
+  (fields (mutable contents)
+          mutex)
+  (sealed #t)
+  (opaque #t))
+
+(define (atomic-stack)
+  (%atomic-stack '() (make-mutex)))
+
+(define (stack->list stack)
+  (stack-contents stack))
+
+(define (push! value stack)
+  (typecheck stack atomic-stack?)
+  (with-mutex (stack-mutex stack)
+    (stack-contents-set!
+     stack
+     (cons value (stack-contents stack)))))
+
+(define (stack-peek stack)
+  (typecheck stack atomic-stack?)
+  (car (stack-contents stack)))
+
+(define (pop! stack)
+  (typecheck stack atomic-stack?)
+  (with-mutex (stack-mutex stack)
+    (guard (_ (else #f))
+      (begin1 (stack-peek stack)
+              (stack-contents-set!
+               stack (cdr (stack-contents stack)))))))
+
diff --git a/module/hnh/util/atomic.scm b/module/hnh/util/atomic.scm
new file mode 100644
index 00000000..1deba2c1
--- /dev/null
+++ b/module/hnh/util/atomic.scm
@@ -0,0 +1,11 @@
+(define-module (hnh util atomic)
+  :use-module (srfi srfi-18)
+  :export (with-mutex))
+
+(define-syntax with-mutex
+  (syntax-rules ()
+    ((_ mutex body ...)
+     (dynamic-wind
+       (lambda () (mutex-lock! mutex))
+       (lambda () body ...)
+       (lambda () (mutex-unlock! mutex))))))
diff --git a/module/hnh/util/coverage.scm b/module/hnh/util/coverage.scm
index 2517e81f..9b76411b 100644
--- a/module/hnh/util/coverage.scm
+++ b/module/hnh/util/coverage.scm
@@ -63,7 +63,7 @@
    (fold (lambda (line state)
            (match (parse-coverage-line line)
              (('DA line hits)
-              (modify state (compose-lens car* lines)
+              (modify state (compose-lenses car* lines)
                       (lambda (lines) (cons (cons line hits) lines))))
              (('SF source)
               (set state car* filename source))
@@ -86,6 +86,7 @@
                "Can only merge coverage data for the same file, got ~s and ~s"
                (list (filename a) (filename b))
                #f))
+  #;
   (unless (= (total-lines a) (total-lines b))
     (scm-error 'misc-error "merge-coverage"
                "Mismatch between found lines. Is it really the same file? File: ~s, got ~s and ~s"
diff --git a/testrunner.scm b/testrunner.scm
index c3fa0ae3..267e3c17 100755
--- a/testrunner.scm
+++ b/testrunner.scm
@@ -1,11 +1,11 @@
 #!/usr/bin/env bash
 # -*- mode: scheme; geiser-scheme-implementation: guile -*-
 
-make calp unit-test-deps
+make calp
+make unit-test-deps
 
 root=$(dirname "$(realpath "$0")")
-eval "$(env __PRINT_ENVIRONMENT=1 ${root}/calp)"
-
+eval "$(env __PRINT_ENVIRONMENT=1 "${root}/calp")"
 
 exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
 !#
@@ -19,26 +19,25 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
              (srfi srfi-18)
              (srfi srfi-64)
              (srfi srfi-71)
-             ((hnh util) :select (->> for group-by))
+             (srfi srfi-111)
+             ((rnrs io ports) :select (get-bytevector-all))
+             ((hnh util) :select (-> ->> for group-by))
              (hnh util path)
              (hnh util type)
-             ((hnh util lens) :select (modify cdr* car* compose-lenses))
              (hnh util object)
              (hnh util coverage)
+             (hnh util atomic)
+             (hnh util atomic-stack)
+             (hnh util atomic-queue)
+             (hnh test testrunner)
+             ((hnh util io) :select (displayln))
+             (crypto)
              (ice-9 getopt-long)
              (ice-9 control)
              (ice-9 format))
 
 
 
-(define-syntax with-mutex
-  (syntax-rules ()
-    ((_ mutex body ...)
-     (dynamic-wind
-       (lambda () (mutex-lock! mutex))
-       (lambda () body ...)
-       (lambda () (mutex-unlock! mutex))))))
-
 (define-syntax-rule (begin-thread forms ...)
   (let ((thread (make-thread (lambda () forms ...))))
     (thread-start! thread)
@@ -66,34 +65,16 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
 
 (define current-filename (make-parameter #f))
 
-(define (construct-test-runner)
-  (define runner (test-runner-null))
-  (test-runner-aux-value!
-   runner
-   `((thread-name . ,(thread-name (current-thread)))))
-  #;
-  (test-runner-on-test-begin! runner
-    (lambda (runner)
-      (test-runner-aux-value! runner #t)))
-  (test-runner-on-test-end! runner
-    (lambda (runner)
-      (case (test-result-kind runner)
-        ((pass)
-         (if (getenv "VERBOSE")
-             (println (format #f "~a SUCCEED ~a"
-                              (current-filename)
-                              (test-runner-test-name runner)))
-             (display #\#)))
-        ((fail)
-         (println (format #f "~a FAIL ~a"
-                          (current-filename)
-                          (test-runner-test-name runner))))
-        ((xpass xfail skip)
-         (println (format #f "~a ~a ~a"
-                          (current-filename)
-                          (test-result-kind runner)
-                          (test-runner-test-name runner)))))))
-  runner)
+(define (test-runner-name runner)
+ (cond ((test-runner-test-name runner)
+        (negate string-null?) => identity)
+       ((test-result-ref runner 'expected-value)
+        => (lambda (p) (with-output-to-string
+                    (lambda ()
+                      ;; (display (bold "[SOURCE]: "))
+                      ;; (truncated-print p width: 60)
+                      (write p)
+                      ))))))
 
 
 (define (test-runner-processed runner)
@@ -114,19 +95,20 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
                 (else
                  (string-join (test-runner-group-path runner) " → ")))))
 
-(define runners '())
-(define runner-mutex (make-mutex))
+
+
+(define runners (atomic-stack))
+
 (sigaction SIGINT
-(lambda _
+  (lambda _
     (display
-    (string-join (map test-runner-test-description runners) "\n"))))
-
+     (string-join (map test-runner-test-description (stack->list runners))
+                  "\n"))))
 
 (define-type (job)
   (jobname type: string?)
   (job-thunk type: thunk?))
 
-
 (define* (maybe-with-code-coverage thunk key: (coverage? #f))
   (if coverage?
       (with-code-coverage
@@ -141,15 +123,13 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
         (lambda ()
           (parameterize ((current-filename (basename entry)))
             (test-begin entry)
-            (with-mutex runner-mutex
-              (set! runners (cons (test-runner-get) runners)))
+            (push! (test-runner-get) runners)
             (let ((coverage module-names
                             (maybe-with-code-coverage
                              (lambda () (load entry))
                              coverage?: coverage?)))
               (let ((tested-files (map module->source-file module-names)))
                 (test-end entry)
-                (println (format #f "Completed ~a" entry))
                 (if coverage
                     (let ((lcov-data
                            (call-with-output-string
@@ -162,28 +142,20 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
 
 
 (define* (make-work-pool jobs key: (thread-count 1))
-  (define job-pool jobs)
-  (define pool-mutex (make-mutex))
-
-  (define results (list))
-  (define results-mutex (make-mutex))
+  (define job-pool (atomic-stack))
+  (define results (atomic-stack))
+  (for-each (lambda (job) (push! job job-pool)) jobs)
 
   (define (pool-worker)
     (call/ec
      (lambda (return)
        (while #t
-         (let ((job (with-mutex pool-mutex
-                      (if (null? job-pool)
-                          (return #f)
-                          (let ((job (car job-pool)))
-                            (set! job-pool (cdr job-pool))
-                            job)))))
+         (let ((job (pop! job-pool)))
+           (unless job (return #f))
            (catch #t
-             (lambda ()
-               (let ((result ((job-thunk job))))
-                 (with-mutex results-mutex
-                   (set! results (cons result results)))))
+             (lambda () (push! ((job-thunk job)) results))
              (lambda args
+               ;; TODO indicate FATAL ERROR
                (println (format #f "Job [~a] failed: ~s"
                                 (jobname job)
                                 ;; TODO better error formatting
@@ -218,6 +190,7 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@"
     (nice (value #t))
     (threads (value #t))
     (coverage (value optional))
+    (coverage-supplement (value #t))
     ))
 
 (define help "
@@ -249,18 +222,31 @@ Flags:
 --coverage [output-filename]
   Generate code coverage data, this causes the tests to be quite
   a bit slower.
+--coverage-supplement supplement-file
 ")
 
 
+
+(define (read-coverage-info port)
+  (map (lambda (entry)
+         (call-with-values (lambda () (apply values entry))
+           (lambda (filename checksum . lines)
+             (cons checksum
+                   (coverage-info
+                    filename: (realpath filename)
+                    lines: (map (lambda (l) (cons l 1)) lines))))))
+       (read port)))
+
+
+
 (define (main args)
   (define options (getopt-long args option-spec))
 
   (when (option-ref options 'help #f)
-    (display help)
     (exit 0))
 
-  (when (option-ref options 'verbose #f)
-    (setenv "VERBOSE" "1"))
+  (when (option-ref options 'verbose (getenv "VERBOSE"))
+    (verbose? #t))
 
   (define test-files
     (cond ((option-ref options 'suite #f)
@@ -271,7 +257,9 @@ Flags:
 
   (nice (string->number (option-ref options 'nice "10")))
 
-  (test-runner-factory construct-test-runner)
+  (define error-queue (atomic-queue))
+
+  (test-runner-factory (construct-test-runner print error-queue))
 
   (define coverage
     (let ((cov (option-ref options 'coverage #f)))
@@ -279,21 +267,58 @@ Flags:
             (cov "coverage.info")
             (else #f))))
 
+  ;; Guile's coverage system sometimes miss some definitions.
+  ;; Add these here so the output gets green.
+  ;; However, always start by attempting to add more tests to fill
+  ;; in the coverage.
+  (define-values (extra-coverage outdated-extra)
+    (cond ((option-ref options 'coverage-supplement #f)
+           => (lambda (supplement-file)
+                (partition
+                 (lambda (pair)
+                   (let ((checksum coverage (car+cdr pair)))
+                     (-> (call-with-input-file (filename coverage)
+                           get-bytevector-all)
+                         sha256
+                         checksum->string
+                         (string=? checksum))))
+                 (call-with-input-file supplement-file read-coverage-info))))
+          (else (values '() '()))))
+
+  (unless (null? outdated-extra)
+    (format #t "The following files have changed since their coverage")
+    (format #t "exceptions were written. Please review:~%")
+    (for-each displayln outdated-extra))
+
   ((@ (hnh util exceptions) warnings-are-errors) #t)
 
   (if (option-ref options 'list #f)
       (format #t "Gathered the following tests:~%~y~%" test-files)
-      (let ((results (thread-join!
-                      (make-work-pool
-                       (prepare-jobs test-files coverage?: coverage)
-                       thread-count: (string->number
-                                      (option-ref options 'threads "1"))))))
-        (define merged-coverages
-          (map (lambda (group) (reduce merge-coverage #f (cdr group)))
-               (group-by filename (concatenate results))))
-
-        (unless (null? merged-coverages)
-          (with-output-to-file coverage
-            (lambda ()
-              (display "TN:") (newline)
-              (for-each output-coverage merged-coverages)))))))
+      (begin
+        (test-begin "Universe")
+        (let ((results (thread-join!
+                        (make-work-pool
+                         (prepare-jobs test-files coverage?: coverage)
+                         thread-count: (string->number
+                                        (option-ref options 'threads "1"))))))
+
+          (test-end "Universe")
+          (define merged-coverages
+            (map (lambda (group) (reduce merge-coverage #f (cdr group)))
+                 (group-by filename (concatenate (cons (map cdr extra-coverage)
+                                                       (stack->list results))))))
+
+
+          (unless (null? merged-coverages)
+            (with-output-to-file coverage
+              (lambda ()
+                (display "TN:") (newline)
+                (for-each output-coverage merged-coverages))))
+
+          (display "== Gathered errors ==\n")
+          (let loop ()
+            (cond ((dequeue! error-queue)
+                   => (lambda (entry)
+                        (display entry)
+                        (newline)
+                        (loop)))))))))
diff --git a/tests/unit/coverage-supplement.scm b/tests/unit/coverage-supplement.scm
new file mode 100644
index 00000000..9fb2f6d6
--- /dev/null
+++ b/tests/unit/coverage-supplement.scm
@@ -0,0 +1,13 @@
+;;; Guile's coverage system sometimes miss some definitions.
+;;; Add these here so the output gets green.
+;;; However, always start by attempting to add more tests to fill
+;;; in the coverage.
+;;;
+;;; Each entry in this file should be a list consisting of:
+;;; - The filename, relative calp's root
+;;; - The sha256-sum of that file
+;;; - Any number of lines which should be marked as covered.
+(("module/vcomponent/base.scm"
+  "f98a3887020c400595bcc32805f968ebebca685bc1c18ef1f1531f55d9f72ec1"
+  73 83 108 1)
+ )
diff --git a/tests/unit/util/atomic-queue.scm b/tests/unit/util/atomic-queue.scm
new file mode 100644
index 00000000..428f4457
--- /dev/null
+++ b/tests/unit/util/atomic-queue.scm
@@ -0,0 +1,32 @@
+(define-module (test atomic-queue)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util atomic-queue))
+
+;;; TODO multithreaded tests
+
+(define q (atomic-queue))
+
+(enqueue! 1 q)
+(enqueue! 2 q)
+(enqueue! 3 q)
+
+(test-equal 1 (dequeue! q))
+
+(enqueue! 4 q)
+
+(test-equal 2 (dequeue! q))
+(test-equal 3 (dequeue! q))
+(test-equal 4 (dequeue! q))
+(test-equal #f (dequeue! q))
+(test-equal #f (dequeue! q))
+
+(test-group "Errors are capturable"
+ (catch #t
+   (lambda ()
+     (queue-peek q)
+     (test-assert "Should never be reached" #f))
+   (lambda _ (test-assert #t "Error correctly captured"))))
+
+
+'((hnh util atomic-queue))
diff --git a/tests/unit/util/atomic-stack.scm b/tests/unit/util/atomic-stack.scm
new file mode 100644
index 00000000..46a16bfb
--- /dev/null
+++ b/tests/unit/util/atomic-stack.scm
@@ -0,0 +1,25 @@
+(define-module (test atomic-stack)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util atomic-stack))
+
+(define stack (atomic-stack))
+
+(test-equal "Fresh stacks are empty"
+  '() (stack->list stack))
+
+(push! 1 stack)
+(push! 2 stack)
+(push! 3 stack)
+
+(test-equal "Stack contents when content"
+  '(3 2 1) (stack->list stack))
+
+(test-equal "Poped correctly 3" 3 (pop! stack))
+(push! 4 stack)
+(test-equal "Poped correctly 4" 4 (pop! stack))
+(test-equal "Poped correctly 2" 2 (pop! stack))
+(test-equal "Poped correctly 1" 1 (pop! stack))
+(test-equal "Poped correctly #f" #f (pop! stack))
+
+'((hnh util atomic-stack))