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