listener from hell with chanl

gistfile1.txt

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload '("iup" "chanl" "bordeaux-threads")))

(defpackage #:iup-examples.listener
  (:use #:common-lisp)
  (:export #:listener))

(in-package #:iup-examples.listener)

(defvar *idle-action-lock* (bt:make-lock "idle-action"))

(defun make-listener (channel-in multi-line)
  (bt:make-thread
   (lambda ()
     (loop :for d := (chanl:recv channel-in)
           :for r := (write-to-string (eval (read-from-string d)))
           :do (bt:with-lock-held (*idle-action-lock*)
                 (setf (iup:idle-action)
                       (lambda ()
                         (setf (iup:attribute multi-line :append) r)
                         ;; FIXME how to make this wait for completion?? ^^^ nother lock prob..
                         iup:+ignore+)))))))

(defun listener ()
  (iup:with-iup ()
    (let* ((output (iup:multi-line :expand :yes))
           (input (iup:text :expand :horizontal))
           (interrupt (iup:button :title "Interrupt"))
           (hbox (iup:hbox (list input interrupt)))
           (vbox (iup:vbox (list output hbox)))
           (dialog (iup:dialog vbox
                               :title "Listener from Hell"
                               :size "HALFxHALF")))
      (iup:show dialog)
      (let* ((channel (make-instance 'chanl:unbounded-channel))
             (listener (make-listener channel output)))
        (setf (iup:callback input :k_any)
              (lambda (handle c)
                (when (= c 13)
                  (let ((string (iup:attribute handle :value)))
                    (setf (iup:attribute handle :value) "")
                    (chanl:send channel string)))
                iup:+default+))
        (setf (iup:callback dialog :destroy_cb)
              (bt:destroy-thread listener)))
      (iup:main-loop))))

#-sbcl (listener)

#+sbcl
(sb-int:with-float-traps-masked
    (:divide-by-zero :invalid)
  (listener))