/[slime]/slime/swank-clisp.lisp
ViewVC logotype

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.91 - (show annotations)
Thu Jul 30 17:05:19 2009 UTC (4 years, 8 months ago) by trittweiler
Branch: MAIN
Changes since 1.90: +120 -3 lines
	* swank-clisp.lisp: Clisp 2.48 experimentally supports threads. So
	add infrastructure to use threads in Clisp's swank backend. We do
	not make it the default, because it's not prime time yet. There
	are still problems with GC, weak-pointers, and thread objects.
1 ;;;; -*- indent-tabs-mode: nil -*-
2
3 ;;;; SWANK support for CLISP.
4
5 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
6
7 ;;;; This program is free software; you can redistribute it and/or
8 ;;;; modify it under the terms of the GNU General Public License as
9 ;;;; published by the Free Software Foundation; either version 2 of
10 ;;;; the License, or (at your option) any later version.
11
12 ;;;; This program is distributed in the hope that it will be useful,
13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;;; GNU General Public License for more details.
16
17 ;;;; You should have received a copy of the GNU General Public
18 ;;;; License along with this program; if not, write to the Free
19 ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20 ;;;; MA 02111-1307, USA.
21
22 ;;; This is work in progress, but it's already usable. Many things
23 ;;; are adapted from other swank-*.lisp, in particular from
24 ;;; swank-allegro (I don't use allegro at all, but it's the shortest
25 ;;; one and I found Helmut Eller's code there enlightening).
26
27 ;;; This code will work better with recent versions of CLISP (say, the
28 ;;; last release or CVS HEAD) while it may not work at all with older
29 ;;; versions. It is reasonable to expect it to work on platforms with
30 ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
31 ;;; systems, but also on Win32. This backend uses the portable xref
32 ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
33 ;;; are conveniently included in SLIME.
34
35 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
36
37 (in-package :swank-backend)
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 ;;(use-package "SOCKET")
41 (use-package "GRAY"))
42
43 ;;;; if this lisp has the complete CLOS then we use it, otherwise we
44 ;;;; build up a "fake" swank-mop and then override the methods in the
45 ;;;; inspector.
46
47 (eval-when (:compile-toplevel :load-toplevel :execute)
48 (defvar *have-mop*
49 (and (find-package :clos)
50 (eql :external
51 (nth-value 1 (find-symbol (string ':standard-slot-definition)
52 :clos))))
53 "True in those CLISP images which have a complete MOP implementation."))
54
55 #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
56 (progn
57 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
58
59 (defun swank-mop:slot-definition-documentation (slot)
60 (clos::slot-definition-documentation slot)))
61
62 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
63 (defclass swank-mop:standard-slot-definition ()
64 ()
65 (:documentation
66 "Dummy class created so that swank.lisp will compile and load."))
67
68 ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
69 ;; (progn
70 ;; (defmacro with-blocked-signals ((&rest signals) &body body)
71 ;; (ext:with-gensyms ("SIGPROCMASK" ret mask)
72 ;; `(multiple-value-bind (,ret ,mask)
73 ;; (linux:sigprocmask-set-n-save
74 ;; ,linux:SIG_BLOCK
75 ;; ,(do ((sigset (linux:sigset-empty)
76 ;; (linux:sigset-add sigset (the fixnum (pop signals)))))
77 ;; ((null signals) sigset)))
78 ;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
79 ;; (unwind-protect
80 ;; (progn ,@body)
81 ;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
82
83 ;; (defimplementation call-without-interrupts (fn)
84 ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
85
86 ;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and))
87 (defimplementation call-without-interrupts (fn)
88 (funcall fn))
89
90 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
91 ;; old name prior to 2005-03-01, clisp <= 2.33.2
92 (find-symbol "PROGRAM-ID" :system)
93 #+win32 ; integrated into the above since 2005-02-24
94 (and (find-package :win32) ; optional modules/win32
95 (find-symbol "GetCurrentProcessId" :win32)))))
96 (defimplementation getpid () ; a required interface
97 (cond
98 (getpid (funcall getpid))
99 #+win32 ((ext:getenv "PID")) ; where does that come from?
100 (t -1))))
101
102 (defimplementation call-with-user-break-handler (handler function)
103 (handler-bind ((system::simple-interrupt-condition
104 (lambda (c)
105 (declare (ignore c))
106 (funcall handler)
107 (when (find-restart 'socket-status)
108 (invoke-restart (find-restart 'socket-status)))
109 (continue))))
110 (funcall function)))
111
112 (defimplementation lisp-implementation-type-name ()
113 "clisp")
114
115 (defimplementation set-default-directory (directory)
116 (setf (ext:default-directory) directory)
117 (namestring (setf *default-pathname-defaults* (ext:default-directory))))
118
119 (defimplementation filename-to-pathname (string)
120 (cond ((member :cygwin *features*)
121 (parse-cygwin-filename string))
122 (t (parse-namestring string))))
123
124 (defun parse-cygwin-filename (string)
125 (multiple-value-bind (match _ drive absolute)
126 (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
127 (declare (ignore _))
128 (assert (and match (if drive absolute t)) ()
129 "Invalid filename syntax: ~a" string)
130 (let* ((sans-prefix (subseq string (regexp:match-end match)))
131 (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
132 (path (loop for name in path collect
133 (cond ((equal name "..") ':back)
134 (t name))))
135 (directoryp (or (equal string "")
136 (find (aref string (1- (length string))) "\\/"))))
137 (multiple-value-bind (file type)
138 (cond ((and (not directoryp) (last path))
139 (let* ((file (car (last path)))
140 (pos (position #\. file :from-end t)))
141 (cond ((and pos (> pos 0))
142 (values (subseq file 0 pos)
143 (subseq file (1+ pos))))
144 (t file)))))
145 (make-pathname :host nil
146 :device nil
147 :directory (cons
148 (if absolute :absolute :relative)
149 (let ((path (if directoryp
150 path
151 (butlast path))))
152 (if drive
153 (cons
154 (regexp:match-string string drive)
155 path)
156 path)))
157 :name file
158 :type type)))))
159
160 ;;;; TCP Server
161
162 (defimplementation create-socket (host port)
163 (declare (ignore host))
164 (socket:socket-server port))
165
166 (defimplementation local-port (socket)
167 (socket:socket-server-port socket))
168
169 (defimplementation close-socket (socket)
170 (socket:socket-server-close socket))
171
172 (defimplementation accept-connection (socket
173 &key external-format buffering timeout)
174 (declare (ignore buffering timeout))
175 (socket:socket-accept socket
176 :buffered nil ;; XXX should be t
177 :element-type 'character
178 :external-format external-format))
179
180 #-win32
181 (defimplementation wait-for-input (streams &optional timeout)
182 (assert (member timeout '(nil t)))
183 (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
184 (loop
185 (cond ((check-slime-interrupts) (return :interrupt))
186 (timeout
187 (socket:socket-status streams 0 0)
188 (return (loop for (s _ . x) in streams
189 if x collect s)))
190 (t
191 (with-simple-restart (socket-status "Return from socket-status.")
192 (socket:socket-status streams 0 500000))
193 (let ((ready (loop for (s _ . x) in streams
194 if x collect s)))
195 (when ready (return ready))))))))
196
197 ;;;; Coding systems
198
199 (defvar *external-format-to-coding-system*
200 '(((:charset "iso-8859-1" :line-terminator :unix)
201 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
202 ((:charset "iso-8859-1":latin-1)
203 "latin-1" "iso-latin-1" "iso-8859-1")
204 ((:charset "utf-8") "utf-8")
205 ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
206 ((:charset "euc-jp") "euc-jp")
207 ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
208 ((:charset "us-ascii") "us-ascii")
209 ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
210
211 (defimplementation find-external-format (coding-system)
212 (let ((args (car (rassoc-if (lambda (x)
213 (member coding-system x :test #'equal))
214 *external-format-to-coding-system*))))
215 (and args (apply #'ext:make-encoding args))))
216
217
218 ;;;; Swank functions
219
220 (defimplementation arglist (fname)
221 (block nil
222 (or (ignore-errors
223 (let ((exp (function-lambda-expression fname)))
224 (and exp (return (second exp)))))
225 (ignore-errors
226 (return (ext:arglist fname)))
227 :not-available)))
228
229 (defimplementation macroexpand-all (form)
230 (ext:expand-form form))
231
232 (defimplementation describe-symbol-for-emacs (symbol)
233 "Return a plist describing SYMBOL.
234 Return NIL if the symbol is unbound."
235 (let ((result ()))
236 (flet ((doc (kind)
237 (or (documentation symbol kind) :not-documented))
238 (maybe-push (property value)
239 (when value
240 (setf result (list* property value result)))))
241 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
242 (when (fboundp symbol)
243 (maybe-push
244 ;; Report WHEN etc. as macros, even though they may be
245 ;; implemented as special operators.
246 (if (macro-function symbol) :macro
247 (typecase (fdefinition symbol)
248 (generic-function :generic-function)
249 (function :function)
250 ;; (type-of 'progn) -> ext:special-operator
251 (t :special-operator)))
252 (doc 'function)))
253 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
254 (get symbol 'system::setf-expander)); defsetf
255 (maybe-push :setf (doc 'setf)))
256 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
257 (get symbol 'system::defstruct-description)
258 (get symbol 'system::deftype-expander))
259 (maybe-push :type (doc 'type))) ; even for 'structure
260 (when (find-class symbol nil)
261 (maybe-push :class (doc 'type)))
262 ;; Let this code work compiled in images without FFI
263 (let ((types (load-time-value
264 (and (find-package "FFI")
265 (symbol-value
266 (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
267 ;; Use ffi::*c-type-table* so as not to suffer the overhead of
268 ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
269 ;; which are not FFI type names.
270 (when (and types (nth-value 1 (gethash symbol types)))
271 ;; Maybe use (case (head (ffi:deparse-c-type)))
272 ;; to distinguish struct and union types?
273 (maybe-push :alien-type :not-documented)))
274 result)))
275
276 (defimplementation describe-definition (symbol namespace)
277 (ecase namespace
278 (:variable (describe symbol))
279 (:macro (describe (macro-function symbol)))
280 (:function (describe (symbol-function symbol)))
281 (:class (describe (find-class symbol)))))
282
283 (defun fspec-pathname (spec)
284 (let ((path spec)
285 type
286 lines)
287 (when (consp path)
288 (psetq type (car path)
289 path (cadr path)
290 lines (cddr path)))
291 (when (and path
292 (member (pathname-type path)
293 custom:*compiled-file-types* :test #'equal))
294 (setq path
295 (loop for suffix in custom:*source-file-types*
296 thereis (probe-file (make-pathname :defaults path
297 :type suffix)))))
298 (values path type lines)))
299
300 (defun fspec-location (name fspec)
301 (multiple-value-bind (file type lines)
302 (fspec-pathname fspec)
303 (list (if type (list name type) name)
304 (cond (file
305 (multiple-value-bind (truename c) (ignore-errors (truename file))
306 (cond (truename
307 (make-location (list :file (namestring truename))
308 (if (consp lines)
309 (list* :line lines)
310 (list :function-name (string name)))
311 (when (consp type)
312 (list :snippet (format nil "~A" type)))))
313 (t (list :error (princ-to-string c))))))
314 (t (list :error (format nil "No source information available for: ~S"
315 fspec)))))))
316
317 (defimplementation find-definitions (name)
318 (mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file)))
319
320 (defun trim-whitespace (string)
321 (string-trim #(#\newline #\space #\tab) string))
322
323 (defvar *sldb-backtrace*)
324
325 (eval-when (:compile-toplevel :load-toplevel :execute)
326 (when (string< "2.44" (lisp-implementation-version))
327 (pushnew :clisp-2.44+ *features*)))
328
329 (defun sldb-backtrace ()
330 "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
331 (do ((frames '())
332 (last nil frame)
333 (frame (sys::the-frame)
334 #+clisp-2.44+ (sys::frame-up 1 frame 1)
335 #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
336 ((eq frame last) (nreverse frames))
337 (unless (boring-frame-p frame)
338 (push frame frames))))
339
340 (defimplementation call-with-debugging-environment (debugger-loop-fn)
341 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
342 ;;(sys::*driver* debugger-loop-fn)
343 ;;(sys::*fasoutput-stream* nil)
344 (*sldb-backtrace*
345 (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
346 (funcall debugger-loop-fn)))
347
348 (defun nth-frame (index)
349 (nth index *sldb-backtrace*))
350
351 (defun boring-frame-p (frame)
352 (member (frame-type frame) '(stack-value bind-var bind-env)))
353
354 (defun frame-to-string (frame)
355 (with-output-to-string (s)
356 (sys::describe-frame s frame)))
357
358 ;; FIXME: they changed the layout in 2.44 so the frame-to-string &
359 ;; string-matching silliness no longer works.
360 (defun frame-type (frame)
361 ;; FIXME: should bind *print-length* etc. to small values.
362 (frame-string-type (frame-to-string frame)))
363
364 (defvar *frame-prefixes*
365 '(("frame binding variables" bind-var)
366 ("<1> #<compiled-function" compiled-fun)
367 ("<1> #<system-function" sys-fun)
368 ("<1> #<special-operator" special-op)
369 ("EVAL frame" eval)
370 ("APPLY frame" apply)
371 ("compiled tagbody frame" compiled-tagbody)
372 ("compiled block frame" compiled-block)
373 ("block frame" block)
374 ("nested block frame" block)
375 ("tagbody frame" tagbody)
376 ("nested tagbody frame" tagbody)
377 ("catch frame" catch)
378 ("handler frame" handler)
379 ("unwind-protect frame" unwind-protect)
380 ("driver frame" driver)
381 ("frame binding environments" bind-env)
382 ("CALLBACK frame" callback)
383 ("- " stack-value)
384 ("<1> " fun)
385 ("<2> " 2nd-frame)))
386
387 (defun frame-string-type (string)
388 (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
389 *frame-prefixes*)))
390
391 (defimplementation compute-backtrace (start end)
392 (let* ((bt *sldb-backtrace*)
393 (len (length bt)))
394 (loop for f in (subseq bt start (min (or end len) len))
395 collect f)))
396
397 (defimplementation print-frame (frame stream)
398 (let* ((str (frame-to-string frame)))
399 (write-string (extract-frame-line str)
400 stream)))
401
402 (defun extract-frame-line (frame-string)
403 (let ((s frame-string))
404 (trim-whitespace
405 (case (frame-string-type s)
406 ((eval special-op)
407 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
408 (apply
409 (string-match "APPLY frame for call \\(.*\\)" s 1))
410 ((compiled-fun sys-fun fun)
411 (extract-function-name s))
412 (t s)))))
413
414 (defun extract-function-name (string)
415 (let ((1st (car (split-frame-string string))))
416 (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
417 1st
418 1)
419 (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
420 1st)))
421
422 (defun split-frame-string (string)
423 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
424 (mapcar #'car *frame-prefixes*))))
425 (loop for pos = 0 then (1+ (regexp:match-start match))
426 for match = (regexp:match rx string :start pos)
427 if match collect (subseq string pos (regexp:match-start match))
428 else collect (subseq string pos)
429 while match)))
430
431 (defun string-match (pattern string n)
432 (let* ((match (nth-value n (regexp:match pattern string))))
433 (if match (regexp:match-string string match))))
434
435 (defimplementation format-sldb-condition (condition)
436 (trim-whitespace (princ-to-string condition)))
437
438 (defimplementation eval-in-frame (form frame-number)
439 (sys::eval-at (nth-frame frame-number) form))
440
441 (defimplementation frame-locals (frame-number)
442 (let ((frame (nth-frame frame-number)))
443 (loop for i below (%frame-count-vars frame)
444 collect (list :name (%frame-var-name frame i)
445 :value (%frame-var-value frame i)
446 :id 0))))
447
448 (defimplementation frame-var-value (frame var)
449 (%frame-var-value (nth-frame frame) var))
450
451 ;;; Interpreter-Variablen-Environment has the shape
452 ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
453
454 (defun %frame-count-vars (frame)
455 (cond ((sys::eval-frame-p frame)
456 (do ((venv (frame-venv frame) (next-venv venv))
457 (count 0 (+ count (/ (1- (length venv)) 2))))
458 ((not venv) count)))
459 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
460 (length (%parse-stack-values frame)))
461 (t 0)))
462
463 (defun %frame-var-name (frame i)
464 (cond ((sys::eval-frame-p frame)
465 (nth-value 0 (venv-ref (frame-venv frame) i)))
466 (t (format nil "~D" i))))
467
468 (defun %frame-var-value (frame i)
469 (cond ((sys::eval-frame-p frame)
470 (let ((name (venv-ref (frame-venv frame) i)))
471 (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
472 (if c
473 (format-sldb-condition c)
474 v))))
475 ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
476 (let ((str (nth i (%parse-stack-values frame))))
477 (trim-whitespace (subseq str 2))))
478 (t (break "Not implemented"))))
479
480 (defun frame-venv (frame)
481 (let ((env (sys::eval-at frame '(sys::the-environment))))
482 (svref env 0)))
483
484 (defun next-venv (venv) (svref venv (1- (length venv))))
485
486 (defun venv-ref (env i)
487 "Reference the Ith binding in ENV.
488 Return two values: NAME and VALUE"
489 (let ((idx (* i 2)))
490 (if (< idx (1- (length env)))
491 (values (svref env idx) (svref env (1+ idx)))
492 (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
493
494 (defun %parse-stack-values (frame)
495 (labels ((next (fp)
496 #+clisp-2.44+ (sys::frame-down 1 fp 1)
497 #-clisp-2.44+ (sys::frame-down-1 fp 1))
498 (parse (fp accu)
499 (let ((str (frame-to-string fp)))
500 (cond ((is-prefix-p "- " str)
501 (parse (next fp) (cons str accu)))
502 ((is-prefix-p "<1> " str)
503 ;;(when (eq (frame-type frame) 'compiled-fun)
504 ;; (pop accu))
505 (dolist (str (cdr (split-frame-string str)))
506 (when (is-prefix-p "- " str)
507 (push str accu)))
508 (nreverse accu))
509 (t (parse (next fp) accu))))))
510 (parse (next frame) '())))
511
512 (setq *features* (remove :clisp-2.44+ *features*))
513
514 (defun is-prefix-p (pattern string)
515 (not (mismatch pattern string :end2 (min (length pattern)
516 (length string)))))
517
518 (defimplementation return-from-frame (index form)
519 (sys::return-from-eval-frame (nth-frame index) form))
520
521 (defimplementation restart-frame (index)
522 (sys::redo-eval-frame (nth-frame index)))
523
524 (defimplementation frame-source-location (index)
525 `(:error
526 ,(format nil "frame-source-location not implemented. (frame: ~A)"
527 (nth-frame index))))
528
529 ;;;; Profiling
530
531 (defimplementation profile (fname)
532 (eval `(mon:monitor ,fname))) ;monitor is a macro
533
534 (defimplementation profiled-functions ()
535 mon:*monitored-functions*)
536
537 (defimplementation unprofile (fname)
538 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
539
540 (defimplementation unprofile-all ()
541 (mon:unmonitor))
542
543 (defimplementation profile-report ()
544 (mon:report-monitoring))
545
546 (defimplementation profile-reset ()
547 (mon:reset-all-monitoring))
548
549 (defimplementation profile-package (package callers-p methods)
550 (declare (ignore callers-p methods))
551 (mon:monitor-all package))
552
553 ;;;; Handle compiler conditions (find out location of error etc.)
554
555 (defmacro compile-file-frobbing-notes ((&rest args) &body body)
556 "Pass ARGS to COMPILE-FILE, send the compiler notes to
557 *STANDARD-INPUT* and frob them in BODY."
558 `(let ((*error-output* (make-string-output-stream))
559 (*compile-verbose* t))
560 (multiple-value-prog1
561 (compile-file ,@args)
562 (handler-case
563 (with-input-from-string
564 (*standard-input* (get-output-stream-string *error-output*))
565 ,@body)
566 (sys::simple-end-of-file () nil)))))
567
568 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
569 (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
570 (defvar *orig-c-error* (symbol-function 'system::c-error))
571 (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
572
573 (defmacro dynamic-flet (names-functions &body body)
574 "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
575 Execute BODY with NAME's function slot set to FUNCTION."
576 `(ext:letf* ,(loop for (name function) in names-functions
577 collect `((symbol-function ',name) ,function))
578 ,@body))
579
580 (defvar *buffer-name* nil)
581 (defvar *buffer-offset*)
582
583 (defun compiler-note-location ()
584 "Return the current compiler location."
585 (let ((lineno1 sys::*compile-file-lineno1*)
586 (lineno2 sys::*compile-file-lineno2*)
587 (file sys::*compile-file-truename*))
588 (cond ((and file lineno1 lineno2)
589 (make-location (list ':file (namestring file))
590 (list ':line lineno1)))
591 (*buffer-name*
592 (make-location (list ':buffer *buffer-name*)
593 (list ':offset *buffer-offset* 0)))
594 (t
595 (list :error "No error location available")))))
596
597 (defun signal-compiler-warning (cstring args severity orig-fn)
598 (signal (make-condition 'compiler-condition
599 :severity severity
600 :message (apply #'format nil cstring args)
601 :location (compiler-note-location)))
602 (apply orig-fn cstring args))
603
604 (defun c-warn (cstring &rest args)
605 (signal-compiler-warning cstring args :warning *orig-c-warn*))
606
607 (defun c-style-warn (cstring &rest args)
608 (dynamic-flet ((sys::c-warn *orig-c-warn*))
609 (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
610
611 (defun c-error (cstring &rest args)
612 (signal-compiler-warning cstring args :error *orig-c-error*))
613
614 (defimplementation call-with-compilation-hooks (function)
615 (handler-bind ((warning #'handle-notification-condition))
616 (dynamic-flet ((system::c-warn #'c-warn)
617 (system::c-style-warn #'c-style-warn)
618 (system::c-error #'c-error))
619 (funcall function))))
620
621 (defun handle-notification-condition (condition)
622 "Handle a condition caused by a compiler warning."
623 (signal (make-condition 'compiler-condition
624 :original-condition condition
625 :severity :warning
626 :message (princ-to-string condition)
627 :location (compiler-note-location))))
628
629 (defimplementation swank-compile-file (input-file output-file
630 load-p external-format)
631 (with-compilation-hooks ()
632 (with-compilation-unit ()
633 (multiple-value-bind (fasl-file warningsp failurep)
634 (compile-file input-file
635 :output-file output-file
636 :external-format external-format)
637 (values fasl-file warningsp
638 (or failurep
639 (and load-p
640 (not (load fasl-file)))))))))
641
642 (defimplementation swank-compile-string (string &key buffer position filename
643 policy)
644 (declare (ignore filename policy))
645 (with-compilation-hooks ()
646 (let ((*buffer-name* buffer)
647 (*buffer-offset* position))
648 (funcall (compile nil (read-from-string
649 (format nil "(~S () ~A)" 'lambda string))))
650 t)))
651
652 ;;;; Portable XREF from the CMU AI repository.
653
654 (setq pxref::*handle-package-forms* '(cl:in-package))
655
656 (defmacro defxref (name function)
657 `(defimplementation ,name (name)
658 (xref-results (,function name))))
659
660 (defxref who-calls pxref:list-callers)
661 (defxref who-references pxref:list-readers)
662 (defxref who-binds pxref:list-setters)
663 (defxref who-sets pxref:list-setters)
664 (defxref list-callers pxref:list-callers)
665 (defxref list-callees pxref:list-callees)
666
667 (defun xref-results (symbols)
668 (let ((xrefs '()))
669 (dolist (symbol symbols)
670 (push (fspec-location symbol symbol) xrefs))
671 xrefs))
672
673 (when (find-package :swank-loader)
674 (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
675 (lambda ()
676 (let ((home (user-homedir-pathname)))
677 (and (ext:probe-directory home)
678 (probe-file (format nil "~A/.swank.lisp"
679 (namestring (truename home)))))))))
680
681 ;;; Don't set *debugger-hook* to nil on break.
682 (ext:without-package-lock ()
683 (defun break (&optional (format-string "Break") &rest args)
684 (if (not sys::*use-clcs*)
685 (progn
686 (terpri *error-output*)
687 (apply #'format *error-output*
688 (concatenate 'string "*** - " format-string)
689 args)
690 (funcall ext:*break-driver* t))
691 (let ((condition
692 (make-condition 'simple-condition
693 :format-control format-string
694 :format-arguments args))
695 ;;(*debugger-hook* nil)
696 ;; Issue 91
697 )
698 (ext:with-restarts
699 ((continue
700 :report (lambda (stream)
701 (format stream (sys::text "Return from ~S loop")
702 'break))
703 ()))
704 (with-condition-restarts condition (list (find-restart 'continue))
705 (invoke-debugger condition)))))
706 nil))
707
708 ;;;; Inspecting
709
710 (defmethod emacs-inspect ((o t))
711 (let* ((*print-array* nil) (*print-pretty* t)
712 (*print-circle* t) (*print-escape* t)
713 (*print-lines* custom:*inspect-print-lines*)
714 (*print-level* custom:*inspect-print-level*)
715 (*print-length* custom:*inspect-print-length*)
716 (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
717 (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
718 (*package* tmp-pack)
719 (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
720 (let ((inspection (sys::inspect-backend o)))
721 (append (list
722 (format nil "~S~% ~A~{~%~A~}~%" o
723 (sys::insp-title inspection)
724 (sys::insp-blurb inspection)))
725 (loop with count = (sys::insp-num-slots inspection)
726 for i below count
727 append (multiple-value-bind (value name)
728 (funcall (sys::insp-nth-slot inspection)
729 i)
730 `((:value ,name) " = " (:value ,value)
731 (:newline))))))))
732
733 (defimplementation quit-lisp ()
734 #+lisp=cl (ext:quit)
735 #-lisp=cl (lisp:quit))
736
737
738 (defimplementation preferred-communication-style ()
739 nil)
740
741 ;;; FIXME
742 ;;;
743 ;;; Clisp 2.48 added experimental support for threads. Basically, you
744 ;;; can use :SPAWN now, BUT:
745 ;;;
746 ;;; - there are problems with GC, and threads stuffed into weak
747 ;;; hash-tables as is the case for *THREAD-PLIST-TABLE*.
748 ;;;
749 ;;; See test case at
750 ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429
751 ;;;
752 ;;; Even though said to be fixed, it's not:
753 ;;;
754 ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
755 ;;;
756 ;;; - The DYNAMIC-FLET above is an implementation technique that's
757 ;;; probably not sustainable in light of threads. This got to be
758 ;;; rewritten.
759 ;;;
760 ;;; TCR (2009-07-30)
761
762 #+#.(cl:if (cl:find-package "MP") '(:and) '(:or))
763 (progn
764 (defimplementation spawn (fn &key name)
765 (mp:make-thread fn :name name))
766
767 (defvar *thread-plist-table-lock*
768 (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
769
770 (defvar *thread-plist-table* (make-hash-table :weak :key)
771 "A hashtable mapping threads to a plist.")
772
773 (defvar *thread-id-counter* 0)
774
775 (defimplementation thread-id (thread)
776 (mp:with-mutex-lock (*thread-plist-table-lock*)
777 (or (getf (gethash thread *thread-plist-table*) 'thread-id)
778 (setf (getf (gethash thread *thread-plist-table*) 'thread-id)
779 (incf *thread-id-counter*)))))
780
781 (defimplementation find-thread (id)
782 (find id (all-threads)
783 :key (lambda (thread)
784 (getf (gethash thread *thread-plist-table*) 'thread-id))))
785
786 (defimplementation thread-name (thread)
787 ;; To guard against returning #<UNBOUND>.
788 (princ-to-string (mp:thread-name thread)))
789
790 (defimplementation thread-status (thread)
791 (if (thread-alive-p thread)
792 "RUNNING"
793 "STOPPED"))
794
795 (defimplementation make-lock (&key name)
796 (mp:make-mutex :name name :recursive-p t))
797
798 (defimplementation call-with-lock-held (lock function)
799 (mp:with-mutex-lock (lock)
800 (funcall function)))
801
802 (defimplementation current-thread ()
803 (mp:current-thread))
804
805 (defimplementation all-threads ()
806 (mp:list-threads))
807
808 (defimplementation interrupt-thread (thread fn)
809 (mp:thread-interrupt thread :function fn))
810
811 (defimplementation kill-thread (thread)
812 (mp:thread-interrupt thread :function t))
813
814 (defimplementation thread-alive-p (thread)
815 (mp:thread-active-p thread))
816
817 (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
818 (defvar *mailboxes* (list))
819
820 (defstruct (mailbox (:conc-name mailbox.))
821 thread
822 (lock (make-lock :name "MAILBOX.LOCK"))
823 (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
824 (queue '() :type list))
825
826 (defun mailbox (thread)
827 "Return THREAD's mailbox."
828 (mp:with-mutex-lock (*mailboxes-lock*)
829 (or (find thread *mailboxes* :key #'mailbox.thread)
830 (let ((mb (make-mailbox :thread thread)))
831 (push mb *mailboxes*)
832 mb))))
833
834 (defimplementation send (thread message)
835 (let* ((mbox (mailbox thread))
836 (lock (mailbox.lock mbox)))
837 (mp:with-mutex-lock (lock)
838 (setf (mailbox.queue mbox)
839 (nconc (mailbox.queue mbox) (list message)))
840 (mp:exemption-broadcast (mailbox.waitqueue mbox)))))
841
842 (defimplementation receive-if (test &optional timeout)
843 (let* ((mbox (mailbox (current-thread)))
844 (lock (mailbox.lock mbox)))
845 (assert (or (not timeout) (eq timeout t)))
846 (loop
847 (check-slime-interrupts)
848 (mp:with-mutex-lock (lock)
849 (let* ((q (mailbox.queue mbox))
850 (tail (member-if test q)))
851 (when tail
852 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
853 (return (car tail))))
854 (when (eq timeout t) (return (values nil t)))
855 (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
856
857
858 ;;;; Weak hashtables
859
860 (defimplementation make-weak-key-hash-table (&rest args)
861 (apply #'make-hash-table :weak :key args))
862
863 (defimplementation make-weak-value-hash-table (&rest args)
864 (apply #'make-hash-table :weak :value args))
865
866 (defimplementation save-image (filename &optional restart-function)
867 (let ((args `(,filename
868 ,@(if restart-function
869 `((:init-function ,restart-function))))))
870 (apply #'ext:saveinitmem args)))
871
872 ;;; Local Variables:
873 ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
874 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
875 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5