wrappers.lisp

   1 ;;; A collection of wrappers around extended functionality that may be
   2 ;;; different across CL implementations.
   3
   4 ;;; To add support for a new CL implementation, an entry in each of
   5 ;;; these functions must be made for it.
   6
   7 (in-package :lice)
   8
   9 ;;; Weak Pointers
  10
  11 (defun weak-pointer-p (wp)
  12   #+clisp (ext:weak-pointer-p (wp))
  13   #-(or clisp) (declare (ignore wp)))
  14
  15 (defun make-weak-pointer (data)
  16   #+clisp (ext:make-weak-pointer data)
  17   #+cmu (extensions:make-weak-pointer data)
  18   #+sbcl (sb-ext:make-weak-pointer data)
  19   #+(or movitz mcl) data)
  20
  21 (defun weak-pointer-value (wp)
  22   #+clisp (ext:weak-pointer-value wp)
  23   #+cmu (extensions:weak-pointer-value wp)
  24   #+sbcl (sb-ext:weak-pointer-value wp)
  25   #+(or movitz mcl) (values wp t))
  26
  27 ;;; Some wrappers for access to filesystem things. file type, file
  28 ;;; size, ownership, modification date, mode, etc
  29
  30 (defun file-stats (pathname)
  31   "Return some file stats"
  32   #+sbcl
  33   (let ((stat (sb-posix:lstat pathname)))
  34     (values (sb-posix:stat-mode stat)
  35             (sb-posix:stat-size stat)
  36             (sb-posix:stat-uid stat)
  37             (sb-posix:stat-gid stat)
  38             (sb-posix:stat-mtime stat)))
  39   #+clisp
  40   (let ((stat (sys::file-stat pathname)))
  41     (values (butlast (sys::file-stat-mode stat))
  42             (sys::file-stat-size stat)
  43             (sys::file-stat-uid stat)
  44             (sys::file-stat-gid stat)
  45             (sys::file-stat-mtime stat)))
  46   #-(or sbcl clisp)
  47   (error "Not implemented"))
  48
  49 ;;; subprocesses
  50
  51 (defun run-program (program args &key (output :stream) (error :stream) (input :stream) (sentinel nil))
  52   #+sbcl (let ((p (sb-ext:run-program program args :output output :error error :input input :status-hook sentinel)))
  53            (values p
  54                    (sb-ext:process-input p)
  55                    (sb-ext:process-output p)
  56                    (sb-ext:process-error p)))
  57   #-sbcl (error "Not implemented"))
  58
  59 (defun internal-process-alive-p (process)
  60   #+sbcl (sb-ext:process-alive-p process)
  61   #-sbcl (error "Not implemented"))
  62
  63 (defun internal-process-kill (process &optional (signal 3))
  64   #+sbcl (sb-ext:process-kill process signal)
  65   #-(or sbcl) (error "Not implemented"))
  66
  67 ;;; threads
  68
  69 (defun make-thread (function)
  70   #+sbcl (sb-thread:make-thread function)
  71   #-(or sbcl) (error "Not implemented"))
  72
  73 (defun thread-alive-p (thread)
  74   #+sbcl (sb-thread:thread-alive-p thread)
  75   #-(or sbcl) (error "Not implemented"))
  76
  77 (defun kill-thread (thread)
  78   #+sbcl (sb-thread:terminate-thread thread)
  79   #-(or sbcl) (error "Not implemented"))
  80
  81 (defun make-mutex ()
  82   #+sbcl (sb-thread:make-mutex)
  83   #-(or sbcl) (error "Not implemented"))
  84
  85 (defmacro with-mutex ((mutex) &body body)
  86   #+sbcl `(sb-thread:with-mutex (,mutex) ,@body)
  87   #-(or sbcl) (error "Not implemented"))
  88
  89 ;;; environment
  90
  91 (defun getenv (var)
  92   "Return the value of the environment variable."
  93   #+clisp (ext:getenv (string var))
  94   #+sbcl (sb-posix:getenv (string var))
  95   #-(or clisp sbcl)
  96   (error "Not implemented"))
  97
  98 ;;; debugger
  99
 100 (defun backtrace-as-string (&optional (depth most-positive-fixnum))
 101   (with-output-to-string (s)
 102     #+sbcl (sb-debug:backtrace depth s)
 103     #-(or sbcl)
 104     (error "Not implemented")))
 105
 106 ;;; terminal manipulation
 107
 108 ;;; SIGINT error. we setup our own error handler.
 109
 110 (define-condition user-break (simple-condition)
 111   ())
 112
 113 #+sbcl
 114 (defun sbcl-sigint-handler (&rest junk)
 115   (declare (ignore junk))
 116   (flet ((break-it ()
 117            (with-simple-restart (continue "continue from break")
 118              (invoke-debugger (make-condition 'user-break
 119                                               :format-control "User break")))))
 120     (sb-thread:interrupt-thread (sb-thread::foreground-thread) #'break-it)))
 121
 122 (defun enable-sigint-handler ()
 123   #+sbcl (sb-unix::enable-interrupt sb-unix::sigint #'sbcl-sigint-handler)
 124
 125   #-(or sbcl) (error "not implemented"))
 126
 127 (defvar *old-term-settings* nil)
 128
 129 (defun term-backup-settings ()
 130   #+sbcl
 131   (setf *old-term-settings* (sb-posix:tcgetattr 0))
 132
 133   #-(or sbcl) (error "not implemented"))
 134
 135 (defun term-restore-settings ()
 136   #+sbcl
 137   (sb-posix:tcsetattr 0 0 *old-term-settings*)
 138
 139   #-(or sbcl) (error "not implemented"))
 140
 141 (defun term-set-quit-char (code)
 142   #+sbcl
 143   (let ((attr (sb-posix:tcgetattr 0))
 144         ;; according to termios.h VINTR is 8
 145         (vintr 8))
 146     (setf (aref (sb-posix:termios-cc attr) vintr) code)
 147     (sb-posix:tcsetattr 0 0 attr))
 148
 149   #-(or sbcl) (error "not implemented"))
 150
 151 ;;; two way streams
 152
 153
 154 (provide :lice-0.1/wrappers)
 155