From d8a52af2520d14035fc3a36a7aa3569f9856380a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 8 Oct 2023 11:29:21 +0200 Subject: Further rewrite of testrunner. Move many of the atomic procedures into proper libraries. --- module/hnh/util/atomic-stack.scm | 43 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) create mode 100644 module/hnh/util/atomic-stack.scm (limited to 'module/hnh/util/atomic-stack.scm') 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))))))) + -- cgit v1.2.3