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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5