1 ;;; A collection of wrappers around extended functionality that may be
2 ;;; different across CL implementations.
4 ;;; To add support for a new CL implementation, an entry in each of
5 ;;; these functions must be made for it.
7 ;; don't print the unable to optimize notes
8 #+sbcl
(declaim (sb-ext:muffle-conditions sb-ext
:compiler-note
))
14 (defun weak-pointer-p (wp)
15 #+clisp
(ext:weak-pointer-p
(wp))
16 #-
(or clisp
) (declare (ignore wp
)))
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
)
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
))
30 ;;; Some wrappers for access to filesystem things. file type, file
31 ;;; size, ownership, modification date, mode, etc
33 (defun file-stats (pathname)
34 "Return some file stats"
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
)))
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
)))
50 (error "Not implemented"))
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
)))
57 (sb-ext:process-input p
)
58 (sb-ext:process-output p
)
59 (sb-ext:process-error p
)))
60 #-sbcl
(error "Not implemented"))
62 (defun internal-process-alive-p (process)
63 #+sbcl
(sb-ext:process-alive-p process
)
64 #-sbcl
(error "Not implemented"))
66 (defun internal-process-kill (process &optional
(signal 3))
67 #+sbcl
(sb-ext:process-kill process signal
)
68 #-
(or sbcl
) (error "Not implemented"))
72 (defun make-thread (function)
73 #+sbcl
(sb-thread:make-thread function
)
74 #-
(or sbcl
) (error "Not implemented"))
76 (defun thread-alive-p (thread)
77 #+sbcl
(sb-thread:thread-alive-p thread
)
78 #-
(or sbcl
) (error "Not implemented"))
80 (defun kill-thread (thread)
81 #+sbcl
(sb-thread:terminate-thread thread
)
82 #-
(or sbcl
) (error "Not implemented"))
85 #+sbcl
(sb-thread:make-mutex
)
86 #-
(or sbcl
) (error "Not implemented"))
88 (defmacro with-mutex
((mutex) &body body
)
89 #+sbcl
`(sb-thread:with-mutex
(,mutex
) ,@body
)
90 #-
(or sbcl
) (error "Not implemented"))
95 "Return the value of the environment variable."
96 #+clisp
(ext:getenv
(string var
))
97 #+sbcl
(sb-posix:getenv
(string var
))
99 (error "Not implemented"))
103 (defun backtrace-as-string (&optional
(depth most-positive-fixnum
))
104 (with-output-to-string (s)
105 #+sbcl
(sb-debug:backtrace depth s
)
107 (error "Not implemented")))
109 ;;; terminal manipulation
111 ;;; SIGINT error. we setup our own error handler.
113 (define-condition user-break
(simple-condition)
117 (defun sbcl-sigint-handler (&rest junk
)
118 (declare (ignore junk
))
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
)))
125 (defun enable-sigint-handler ()
126 #+sbcl
(sb-unix::enable-interrupt sb-unix
::sigint
#'sbcl-sigint-handler
)
128 #-
(or sbcl
) (error "not implemented"))
130 (defvar *old-term-settings
* nil
)
132 (defun term-backup-settings ()
134 (setf *old-term-settings
* (sb-posix:tcgetattr
0))
136 #-
(or sbcl
) (error "not implemented"))
138 (defun term-restore-settings ()
140 (sb-posix:tcsetattr
0 0 *old-term-settings
*)
142 #-
(or sbcl
) (error "not implemented"))
144 (defun term-set-quit-char (code)
146 (let ((attr (sb-posix:tcgetattr
0))
147 ;; according to termios.h VINTR is 8
149 (setf (aref (sb-posix:termios-cc attr
) vintr
) code
)
150 (sb-posix:tcsetattr
0 0 attr
))
152 #-
(or sbcl
) (error "not implemented"))
157 (provide :lice-0.1
/wrappers
)