apiv2/bordeaux-threads.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
   2 ;;;; The above modeline is required for Genera. Do not change.
   3
   4 (in-package :bordeaux-threads-2)
   5
   6 (defconstant +supports-threads-p+
   7   #+thread-support t
   8   #-thread-support nil
   9   "This should be set to T if the running instance has thread support.")
  10
  11 #+thread-support
  12 (eval-when (:compile-toplevel :load-toplevel :execute)
  13   (pushnew :bordeaux-threads *features*))
  14
  15 (defun bool (thing) (if thing t nil))
  16
  17 (define-condition bordeaux-threads-error (error) ())
  18
  19 (define-condition abnormal-exit (bordeaux-threads-error)
  20   ((exit-condition :initarg :condition
  21                    :reader abnormal-exit-condition))
  22   (:report (lambda (condition stream)
  23              (format stream "Thread exited with condition: ~A"
  24                      (abnormal-exit-condition condition)))))
  25
  26 (define-condition bordeaux-threads-simple-error
  27     (simple-error bordeaux-threads-error)
  28   ())
  29
  30 (defun bt-error (msg &rest args)
  31   (error 'bordeaux-threads-simple-error
  32          :format-control msg
  33          :format-arguments args))
  34
  35 (define-condition not-implemented (bordeaux-threads-error)
  36   ())
  37
  38 (define-condition operation-not-implemented (not-implemented)
  39   ((operation :initarg :operation :reader operation-not-implemented-operation))
  40   (:report (lambda (condition stream)
  41              (format stream "Operation not implemented: ~A"
  42                      (operation-not-implemented-operation condition)))))
  43
  44 (define-condition keyarg-not-implemented (not-implemented)
  45   ((operation :initarg :operation :reader keyarg-not-implemented-operation)
  46    (keyarg :initarg :keyarg :reader keyarg-not-implemented-keyarg))
  47   (:report (lambda (condition stream)
  48              (format stream "~A does not implement argument ~S"
  49                      (keyarg-not-implemented-operation condition)
  50                      (keyarg-not-implemented-keyarg condition)))))
  51
  52 (defun signal-not-implemented (op &optional keyarg)
  53   (if keyarg
  54       (error 'keyarg-not-implemented :operation op :keyarg keyarg)
  55       (error 'operation-not-implemented :operation op)))
  56
  57 (defparameter *not-implemented* (make-hash-table :test #'equal))
  58
  59 (defun mark-not-implemented (op &rest features)
  60   (setf (gethash op *not-implemented*) features))
  61
  62 (defun implemented-p (op &optional feature)
  63   (multiple-value-bind (missing-features found)
  64       (gethash op *not-implemented*)
  65     (cond
  66       ((not found)
  67        t)
  68       (t
  69        (if (null feature)
  70            (not (null missing-features))
  71            (find feature missing-features))))))
  72
  73 (defun implemented-p* (op &optional feature)
  74   (if (implemented-p op feature)
  75       '(:and)
  76       '(:or)))
  77
  78 #-sbcl
  79 (define-condition timeout (serious-condition)
  80   ((length :initform nil
  81              :initarg :length
  82              :reader timeout-length))
  83   (:report (lambda (c s)
  84              (if (timeout-length c)
  85                  (format s "A timeout set to ~A seconds occurred."
  86                          (timeout-length c))
  87                  (format s "A timeout occurred.")))))