gistfile1.scm

#!/usr/bin/env gosh
;;; -*- mode: scheme; coding: utf-8 -*-

(use srfi-1)
(use gauche.threads)

(define-class <thread-ring-element> ()
  ((thread)
   (mutex)
   (next :init-keyword :next)))

(define (make-thread-element no next)
  (define (yield elem token)
    (thread-specific-set! (slot-ref elem 'thread) token)
    (mutex-unlock! (slot-ref elem 'mutex)))
  (define (done name)
    (print name)
    (exit 0))
  (define (make-proc elem)
    (lambda ()
      (let loop ()
	(mutex-lock! (slot-ref elem 'mutex))
	(let1 token (thread-specific (slot-ref elem 'thread))
	  (if (<= token 0)
	      (done (thread-name (current-thread)))
	      (yield (slot-ref elem 'next) (- token 1)))
	  (loop)))))
  (let* ((e (make <thread-ring-element> :next next))
	 (t (make-thread (make-proc e) (x->string no)))
	 (m (make-mutex)))
    (slot-set! e 'thread t)
    (slot-set! e 'mutex m)
    (mutex-lock! m)
    (thread-start! t)
    e))

(define (make-thread-ring size)
  (if (<= size 0)
      (error "Argument must be a integer greater than 0.")
      (let* ((seed (make-thread-element size #f))
	     (ring (let loop ((e seed)
			      (size (- size 1)))
		     (if (= size 0)
			 e
			 (loop (make-thread-element size e) (- size 1))))))
	(slot-set! seed 'next ring)
	ring)))

(define (thread-ring-start! ring token)
  (thread-specific-set! (slot-ref ring 'thread) token)
  (mutex-unlock! (slot-ref ring 'mutex))
  (thread-join! (slot-ref ring 'thread)))

(define (dump-thread-ring-state ring)
  (define (dump-state e)
    (format #t "~a: ~a\n" (slot-ref e 'thread) (slot-ref e 'mutex)))
  (dump-state ring)
  (let loop ((ring ring)
	     (current (slot-ref ring 'next)))
    (unless (eq? ring current)
      (dump-state current)
      (loop ring (slot-ref current 'next)))))

;; Usage: gosh thread-ring.scm <ring-size> <count>
(define (main args)
  (receive (size token) (apply values (cdr args))
    (thread-ring-start! (make-thread-ring (x->integer size)) (x->integer token)))
  0)