Bordeaux Threads test

threads.lisp

(require :asdf)
(require :bordeaux-threads)

(defun color-formatter (color)
  (format nil "~a[~am~~?~a[m" #\Esc color #\Esc)) ; The formatter function wants a simple-string.

(defun message (color i thread)
  (let ((color-format (color-formatter color))
	(thread-name (bt:thread-name thread)))
    (format t "~&Hello for the ~? time from the ~? thread.~%"
	    color-format `("~:r" (,i))
	    color-format `("~a" (,thread-name)))))

(defvar *counter* 0)
(defvar *mod* 1)

(defun message-2 (color i thread)
  (declare (ignore thread i))
  (format t "~?" (color-formatter color) '("#" nil))
  (incf *counter*)
  (setf *counter* (mod *counter* *mod*))
  (if (zerop *counter*) (format t "~%")))

(defvar *lock* (bt:make-lock "The Output Lock"))

(defun body (color period &aux (i 0))
  (loop
     (incf i)
     (sleep period)
     (bt:with-lock-held (*lock*)
       (message-2 color i (bt:current-thread))
       (force-output))))

(defvar *periods* '(0.1 0.1 0.1 0.1 0.1 0.1))
(defvar *colors* '("31;1" "32;1" "34;1" "33;1" "35;1" "36;1"))
(setf *mod* (length *periods*))

(defun main ()
  (loop
     for period in *periods*
     and color in *colors*
     do (bt:make-thread
	 (lambda () (body color period))
	 :name (format nil "~as" period)))
  (loop for thread in (bt:all-threads)
     do (bt:join-thread thread)))

(main)