impl-clisp.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
 (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
 (DIR) Log
 (DIR) Files
 (DIR) Refs
 (DIR) Tags
 (DIR) README
 (DIR) LICENSE
       ---
       impl-clisp.lisp (2662B)
       ---
            1 ;;;; -*- indent-tabs-mode: nil -*-
            2 
            3 #|
            4 Copyright 2006, 2007 Greg Pfeil
            5 
            6 Distributed under the MIT license (see LICENSE file)
            7 |#
            8 
            9 (in-package #:bordeaux-threads)
           10 
           11 (deftype thread ()
           12   'mt:thread)
           13 
           14 ;;; Thread Creation
           15 (defun %make-thread (function name)
           16   (mt:make-thread function
           17                   :name name
           18                   :initial-bindings mt:*default-special-bindings*))
           19 
           20 (defun current-thread ()
           21   (mt:current-thread))
           22 
           23 (defun threadp (object)
           24   (mt:threadp object))
           25 
           26 (defun thread-name (thread)
           27   (mt:thread-name thread))
           28 
           29 ;;; Resource contention: locks and recursive locks
           30 
           31 (deftype lock () 'mt:mutex)
           32 
           33 (deftype recursive-lock ()
           34   '(and mt:mutex (satisfies mt:mutex-recursive-p)))
           35 
           36 (defun lock-p (object)
           37   (typep object 'mt:mutex))
           38 
           39 (defun recursive-lock-p (object)
           40   (and (typep object 'mt:mutex)
           41        (mt:mutex-recursive-p object)))
           42 
           43 (defun make-lock (&optional name)
           44   (mt:make-mutex :name (or name "Anonymous lock")))
           45 
           46 (defun acquire-lock (lock &optional (wait-p t))
           47   (mt:mutex-lock lock :timeout (if wait-p nil 0)))
           48 
           49 (defun release-lock (lock)
           50   (mt:mutex-unlock lock))
           51 
           52 (defmacro with-lock-held ((place) &body body)
           53   `(mt:with-mutex-lock (,place) ,@body))
           54 
           55 (defun make-recursive-lock (&optional name)
           56   (mt:make-mutex :name (or name "Anonymous recursive lock")
           57                  :recursive-p t))
           58 
           59 (defmacro with-recursive-lock-held ((place) &body body)
           60   `(mt:with-mutex-lock (,place) ,@body))
           61 
           62 ;;; Resource contention: condition variables
           63 
           64 (defun make-condition-variable (&key name)
           65   (mt:make-exemption :name (or name "Anonymous condition variable")))
           66 
           67 (defun condition-wait (condition-variable lock &key timeout)
           68   (mt:exemption-wait condition-variable lock :timeout timeout)
           69   t)
           70 
           71 (defun condition-notify (condition-variable)
           72   (mt:exemption-signal condition-variable))
           73 
           74 (defun thread-yield ()
           75   (mt:thread-yield))
           76 
           77 ;;; Timeouts
           78 
           79 (defmacro with-timeout ((timeout) &body body)
           80   (once-only (timeout)
           81     `(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
           82        ,@body)))
           83 
           84 ;;; Introspection/debugging
           85 
           86 ;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
           87 (defun all-threads ()
           88   (delete-if-not #'mt:thread-active-p (mt:list-threads)))
           89 
           90 (defun interrupt-thread (thread function &rest args)
           91   (mt:thread-interrupt thread :function function :arguments args))
           92 
           93 (defun destroy-thread (thread)
           94   ;;; VTZ: actually we can kill ourselelf.
           95   ;;; suicide is part of our contemporary life :)
           96   (signal-error-if-current-thread thread)
           97   (mt:thread-interrupt thread :function t))
           98 
           99 (defun thread-alive-p (thread)
          100   (mt:thread-active-p thread))
          101 
          102 (defun join-thread (thread)
          103   (mt:thread-join thread))
          104 
          105 (mark-supported)