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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.161 - (hide annotations)
Tue Apr 2 14:41:08 2013 UTC (12 months, 2 weeks ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.160: +3 -3 lines
Hide SWANK debugger frames on Allegro also when the error is
signalled within threads different from the SLIME REPL's.
E.g. (mp:process-run-function nil (lambda () (error "foo"))).
1 heller 1.79 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
2 heller 1.1 ;;;
3     ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4     ;;;
5 heller 1.60 ;;; Created 2003
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 heller 1.74 ;;; are disclaimed.
9 heller 1.1 ;;;
10    
11 heller 1.21 (in-package :swank-backend)
12    
13 heller 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
14     (require :sock)
15 heller 1.135 (require :process)
16     #+(version>= 8 2)
17     (require 'lldb)
18     )
19    
20 heller 1.79 (import-from :excl *gray-stream-symbols* :swank-backend)
21 heller 1.1
22 mbaringer 1.53 ;;; swank-mop
23    
24 heller 1.60 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
25 mbaringer 1.53
26 mbaringer 1.54 (defun swank-mop:slot-definition-documentation (slot)
27 heller 1.62 (documentation slot t))
28 mbaringer 1.53
29 heller 1.79
30 heller 1.146 ;;;; UTF8
31    
32 heller 1.151 (define-symbol-macro utf8-ef
33     (load-time-value
34     (excl:crlf-base-ef (excl:find-external-format :utf-8))
35     t))
36    
37 heller 1.146 (defimplementation string-to-utf8 (s)
38 heller 1.153 (excl:string-to-octets s :external-format utf8-ef
39     :null-terminate nil))
40 heller 1.146
41     (defimplementation utf8-to-string (u)
42 heller 1.151 (excl:octets-to-string u :external-format utf8-ef))
43 heller 1.146
44    
45 heller 1.8 ;;;; TCP Server
46 heller 1.1
47 heller 1.21 (defimplementation preferred-communication-style ()
48     :spawn)
49 heller 1.12
50 heller 1.148 (defimplementation create-socket (host port &key backlog)
51 heller 1.14 (socket:make-socket :connect :passive :local-port port
52 heller 1.148 :local-host host :reuse-address t
53     :backlog (or backlog 5)))
54 heller 1.5
55 heller 1.10 (defimplementation local-port (socket)
56 heller 1.6 (socket:local-port socket))
57    
58 heller 1.10 (defimplementation close-socket (socket)
59 heller 1.6 (close socket))
60    
61 dcrosher 1.85 (defimplementation accept-connection (socket &key external-format buffering
62     timeout)
63     (declare (ignore buffering timeout))
64 heller 1.94 (let ((s (socket:accept-connection socket :wait t)))
65     (when external-format
66     (setf (stream-external-format s) external-format))
67 heller 1.63 s))
68 heller 1.6
69 heller 1.141 (defimplementation socket-fd (stream)
70     (excl::stream-input-handle stream))
71    
72 heller 1.94 (defvar *external-format-to-coding-system*
73     '((:iso-8859-1
74     "latin-1" "latin-1-unix" "iso-latin-1-unix"
75     "iso-8859-1" "iso-8859-1-unix")
76     (:utf-8 "utf-8" "utf-8-unix")
77     (:euc-jp "euc-jp" "euc-jp-unix")
78     (:us-ascii "us-ascii" "us-ascii-unix")
79     (:emacs-mule "emacs-mule" "emacs-mule-unix")))
80    
81     (defimplementation find-external-format (coding-system)
82     (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
83     *external-format-to-coding-system*)))
84     (and e (excl:crlf-base-ef
85     (excl:find-external-format (car e)
86     :try-variant t)))))
87 heller 1.64
88 heller 1.9 ;;;; Unix signals
89    
90 heller 1.10 (defimplementation getpid ()
91 heller 1.8 (excl::getpid))
92 heller 1.6
93 heller 1.15 (defimplementation lisp-implementation-type-name ()
94     "allegro")
95    
96 pseibel 1.28 (defimplementation set-default-directory (directory)
97 mkoeppe 1.86 (let* ((dir (namestring (truename (merge-pathnames directory)))))
98     (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
99 heller 1.66 dir))
100 pseibel 1.28
101 heller 1.35 (defimplementation default-directory ()
102 heller 1.66 (namestring (excl:current-directory)))
103 heller 1.35
104 heller 1.8 ;;;; Misc
105 heller 1.1
106 heller 1.21 (defimplementation arglist (symbol)
107 lgorrie 1.30 (handler-case (excl:arglist symbol)
108     (simple-error () :not-available)))
109 heller 1.21
110     (defimplementation macroexpand-all (form)
111 sboukarev 1.157 #+(version>= 8 0)
112     (excl::walk-form form)
113     #-(version>= 8 0)
114 heller 1.21 (excl::walk form))
115 heller 1.1
116 heller 1.10 (defimplementation describe-symbol-for-emacs (symbol)
117 heller 1.1 (let ((result '()))
118     (flet ((doc (kind &optional (sym symbol))
119     (or (documentation sym kind) :not-documented))
120     (maybe-push (property value)
121     (when value
122     (setf result (list* property value result)))))
123     (maybe-push
124     :variable (when (boundp symbol)
125     (doc 'variable)))
126     (maybe-push
127     :function (if (fboundp symbol)
128     (doc 'function)))
129     (maybe-push
130     :class (if (find-class symbol nil)
131     (doc 'class)))
132     result)))
133    
134 heller 1.20 (defimplementation describe-definition (symbol namespace)
135     (ecase namespace
136     (:variable
137     (describe symbol))
138     ((:function :generic-function)
139     (describe (symbol-function symbol)))
140     (:class
141     (describe (find-class symbol)))))
142 heller 1.10
143 sboukarev 1.158 (defimplementation type-specifier-p (symbol)
144     (or (ignore-errors
145     (subtypep nil symbol))
146     (not (eq (type-specifier-arglist symbol) :not-available))))
147    
148 heller 1.8 ;;;; Debugger
149    
150 heller 1.1 (defvar *sldb-topframe*)
151 heller 1.4
152 heller 1.10 (defimplementation call-with-debugging-environment (debugger-loop-fn)
153 heller 1.71 (let ((*sldb-topframe* (find-topframe))
154 heller 1.20 (excl::*break-hook* nil))
155 heller 1.4 (funcall debugger-loop-fn)))
156 heller 1.1
157 mkoeppe 1.92 (defimplementation sldb-break-at-start (fname)
158 heller 1.135 ;; :print-before is kind of mis-used but we just want to stuff our
159     ;; break form somewhere. This does not work for setf, :before and
160     ;; :after methods, which need special syntax in the trace call, see
161     ;; ACL's doc/debugging.htm chapter 10.
162 mkoeppe 1.92 (eval `(trace (,fname
163     :print-before
164     ((break "Function start breakpoint of ~A" ',fname)))))
165     `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
166    
167 heller 1.71 (defun find-topframe ()
168 trittweiler 1.125 (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
169     (find-package :swank)))
170 sboukarev 1.143 (top-frame (excl::int-newest-frame (excl::current-thread))))
171 trittweiler 1.125 (loop for frame = top-frame then (next-frame frame)
172     for i from 0
173 sboukarev 1.161 while (and frame (< i 30))
174     when (eq (debugger:frame-name frame) magic-symbol)
175 trittweiler 1.125 return (next-frame frame)
176 sboukarev 1.161 finally (return top-frame))))
177 heller 1.71
178 heller 1.42 (defun next-frame (frame)
179     (let ((next (excl::int-next-older-frame frame)))
180     (cond ((not next) nil)
181     ((debugger:frame-visible-p next) next)
182     (t (next-frame next)))))
183    
184 heller 1.1 (defun nth-frame (index)
185 heller 1.42 (do ((frame *sldb-topframe* (next-frame frame))
186 heller 1.1 (i index (1- i)))
187     ((zerop i) frame)))
188    
189 heller 1.20 (defimplementation compute-backtrace (start end)
190 heller 1.1 (let ((end (or end most-positive-fixnum)))
191 heller 1.42 (loop for f = (nth-frame start) then (next-frame f)
192 heller 1.1 for i from start below end
193 heller 1.117 while f collect f)))
194 heller 1.1
195 heller 1.117 (defimplementation print-frame (frame stream)
196     (debugger:output-frame stream frame :moderate))
197 heller 1.4
198 heller 1.10 (defimplementation frame-locals (index)
199 heller 1.1 (let ((frame (nth-frame index)))
200     (loop for i from 0 below (debugger:frame-number-vars frame)
201 mbaringer 1.19 collect (list :name (debugger:frame-var-name frame i)
202 heller 1.1 :id 0
203 mbaringer 1.19 :value (debugger:frame-var-value frame i)))))
204 heller 1.1
205 heller 1.39 (defimplementation frame-var-value (frame var)
206     (let ((frame (nth-frame frame)))
207     (debugger:frame-var-value frame var)))
208 heller 1.1
209 heller 1.21 (defimplementation disassemble-frame (index)
210 heller 1.135 (let ((frame (nth-frame index)))
211     (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
212     (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
213     (disassemble (debugger:frame-function frame)))))
214 heller 1.21
215 heller 1.128 (defimplementation frame-source-location (index)
216 heller 1.135 (let* ((frame (nth-frame index)))
217     (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
218     (declare (ignore x xx xxx))
219 heller 1.155 (cond ((and pc
220     #+(version>= 8 2)
221     (pc-source-location fun pc)
222     #-(version>= 8 2)
223     (function-source-location fun)))
224 heller 1.136 (t ; frames for unbound functions etc end up here
225     (cadr (car (fspec-definition-locations
226     (car (debugger:frame-expression frame))))))))))
227 heller 1.135
228     (defun function-source-location (fun)
229 heller 1.152 (cadr (car (fspec-definition-locations
230     (xref::object-to-function-name fun)))))
231 heller 1.135
232     #+(version>= 8 2)
233     (defun pc-source-location (fun pc)
234     (let* ((debug-info (excl::function-source-debug-info fun)))
235     (cond ((not debug-info)
236     (function-source-location fun))
237 heller 1.155 (t
238 heller 1.139 (let* ((code-loc (find-if (lambda (c)
239     (<= (- pc (sys::natural-width))
240 heller 1.159 (let ((x (excl::ldb-code-pc c)))
241     (or x -1))
242 heller 1.139 pc))
243     debug-info)))
244     (cond ((not code-loc)
245 heller 1.135 (ldb-code-to-src-loc (aref debug-info 0)))
246     (t
247 heller 1.139 (ldb-code-to-src-loc code-loc))))))))
248 heller 1.135
249     #+(version>= 8 2)
250     (defun ldb-code-to-src-loc (code)
251 heller 1.156 (declare (optimize debug))
252     (let* ((func (excl::ldb-code-func code))
253     (debug-info (excl::function-source-debug-info func))
254 heller 1.159 (start (loop for i from (excl::ldb-code-index code) downto 0
255 heller 1.156 for bpt = (aref debug-info i)
256     for start = (excl::ldb-code-start-char bpt)
257     when start return start))
258 heller 1.136 (src-file (excl:source-file func)))
259 heller 1.155 (cond (start
260 heller 1.136 (buffer-or-file-location src-file start))
261 heller 1.155 (func
262 heller 1.135 (let* ((debug-info (excl::function-source-debug-info func))
263     (whole (aref debug-info 0))
264     (paths (source-paths-of (excl::ldb-code-source whole)
265     (excl::ldb-code-source code)))
266 heller 1.155 (path (if paths (longest-common-prefix paths) '()))
267 heller 1.156 (start 0))
268 heller 1.155 (buffer-or-file
269     src-file
270     (lambda (file)
271     (make-location `(:file ,file)
272 heller 1.138 `(:source-path (0 . ,path) ,start)))
273     (lambda (buffer bstart)
274     (make-location `(:buffer ,buffer)
275     `(:source-path (0 . ,path)
276 heller 1.155 ,(+ bstart start)))))))
277     (t
278     nil))))
279    
280 heller 1.135 (defun longest-common-prefix (sequences)
281     (assert sequences)
282     (flet ((common-prefix (s1 s2)
283     (let ((diff-pos (mismatch s1 s2)))
284     (if diff-pos (subseq s1 0 diff-pos) s1))))
285     (reduce #'common-prefix sequences)))
286    
287     (defun source-paths-of (whole part)
288     (let ((result '()))
289     (labels ((walk (form path)
290     (cond ((eq form part)
291     (push (reverse path) result))
292     ((consp form)
293     (loop for i from 0 while (consp form) do
294     (walk (pop form) (cons i path)))))))
295     (walk whole '())
296     (reverse result))))
297 heller 1.4
298 heller 1.10 (defimplementation eval-in-frame (form frame-number)
299 heller 1.73 (let ((frame (nth-frame frame-number)))
300     ;; let-bind lexical variables
301     (let ((vars (loop for i below (debugger:frame-number-vars frame)
302     for name = (debugger:frame-var-name frame i)
303 heller 1.160 if (typep name '(and symbol (not null) (not keyword)))
304 heller 1.73 collect `(,name ',(debugger:frame-var-value frame i)))))
305 heller 1.160 (debugger:eval-form-in-context
306 heller 1.73 `(let* ,vars ,form)
307     (debugger:environment-of-frame frame)))))
308 heller 1.10
309 heller 1.155 (defimplementation frame-package (frame-number)
310     (let* ((frame (nth-frame frame-number))
311     (exp (debugger:frame-expression frame)))
312     (typecase exp
313 heller 1.156 ((cons symbol) (symbol-package (car exp)))
314     ((cons (cons (eql :internal) (cons symbol)))
315     (symbol-package (cadar exp))))))
316 heller 1.155
317 heller 1.11 (defimplementation return-from-frame (frame-number form)
318     (let ((frame (nth-frame frame-number)))
319     (multiple-value-call #'debugger:frame-return
320     frame (debugger:eval-form-in-context
321 heller 1.20 form
322     (debugger:environment-of-frame frame)))))
323 heller 1.67
324 heller 1.117 (defimplementation frame-restartable-p (frame)
325 heller 1.119 (handler-case (debugger:frame-retryable-p frame)
326     (serious-condition (c)
327     (funcall (read-from-string "swank::background-message")
328     "~a ~a" frame (princ-to-string c))
329     nil)))
330 heller 1.117
331 heller 1.11 (defimplementation restart-frame (frame-number)
332     (let ((frame (nth-frame frame-number)))
333 heller 1.69 (cond ((debugger:frame-retryable-p frame)
334     (apply #'debugger:frame-retry frame (debugger:frame-function frame)
335     (cdr (debugger:frame-expression frame))))
336     (t "Frame is not retryable"))))
337 heller 1.67
338 heller 1.8 ;;;; Compiler hooks
339    
340 heller 1.1 (defvar *buffer-name* nil)
341     (defvar *buffer-start-position*)
342     (defvar *buffer-string*)
343 lgorrie 1.33 (defvar *compile-filename* nil)
344 heller 1.1
345 heller 1.66 (defun compiler-note-p (object)
346     (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
347    
348 trittweiler 1.131 (defun redefinition-p (condition)
349     (and (typep condition 'style-warning)
350     (every #'char-equal "redefin" (princ-to-string condition))))
351    
352 heller 1.66 (defun compiler-undefined-functions-called-warning-p (object)
353     (typep object 'excl:compiler-undefined-functions-called-warning))
354 heller 1.64
355     (deftype compiler-note ()
356     `(satisfies compiler-note-p))
357    
358 trittweiler 1.131 (deftype redefinition ()
359     `(satisfies redefinition-p))
360    
361 heller 1.66 (defun signal-compiler-condition (&rest args)
362 sboukarev 1.154 (apply #'signal 'compiler-condition args))
363 heller 1.66
364 heller 1.1 (defun handle-compiler-warning (condition)
365 heller 1.66 (declare (optimize (debug 3) (speed 0) (space 0)))
366 heller 1.159 (cond ((and (not *buffer-name*)
367 heller 1.66 (compiler-undefined-functions-called-warning-p condition))
368     (handle-undefined-functions-warning condition))
369 heller 1.159 ((and (typep condition 'excl::compiler-note)
370     (let ((format (slot-value condition 'excl::format-control)))
371     (and (search "Closure" format)
372     (search "will be stack allocated" format))))
373     ;; Ignore "Closure <foo> will be stack allocated" notes.
374     ;; That occurs often but is usually uninteresting.
375     )
376 heller 1.66 (t
377     (signal-compiler-condition
378     :original-condition condition
379     :severity (etypecase condition
380 trittweiler 1.131 (redefinition :redefinition)
381     (style-warning :style-warning)
382     (warning :warning)
383 trittweiler 1.126 (compiler-note :note)
384 trittweiler 1.131 (reader-error :read-error)
385     (error :error))
386 heller 1.66 :message (format nil "~A" condition)
387 heller 1.159 :location (if (typep condition 'reader-error)
388 trittweiler 1.126 (location-for-reader-error condition)
389     (location-for-warning condition))))))
390 heller 1.66
391     (defun location-for-warning (condition)
392 heller 1.1 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
393 heller 1.66 (cond (*buffer-name*
394     (make-location
395     (list :buffer *buffer-name*)
396 heller 1.114 (list :offset *buffer-start-position* 0)))
397 heller 1.66 (loc
398     (destructuring-bind (file . pos) loc
399 heller 1.133 (let ((start (cond ((consp pos) ; 8.2 and newer
400     (car pos))
401     (t pos))))
402     (make-location
403     (list :file (namestring (truename file)))
404     (list :position (1+ start))))))
405 heller 1.66 (t
406 sboukarev 1.130 (make-error-location "No error location available.")))))
407 heller 1.66
408 trittweiler 1.126 (defun location-for-reader-error (condition)
409     (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
410     (file (pathname (stream-error-stream condition))))
411     (if (integerp pos)
412     (if *buffer-name*
413     (make-location `(:buffer ,*buffer-name*)
414 heller 1.135 `(:offset ,*buffer-start-position* ,pos))
415 trittweiler 1.126 (make-location `(:file ,(namestring (truename file)))
416     `(:position ,pos)))
417 sboukarev 1.130 (make-error-location "No error location available."))))
418 trittweiler 1.126
419 heller 1.133 ;; TODO: report it as a bug to Franz that the condition's plist
420     ;; slot contains (:loc nil).
421 heller 1.66 (defun handle-undefined-functions-warning (condition)
422     (let ((fargs (slot-value condition 'excl::format-arguments)))
423 heller 1.133 (loop for (fname . locs) in (car fargs) do
424     (dolist (loc locs)
425     (multiple-value-bind (pos file) (ecase (length loc)
426     (2 (values-list loc))
427     (3 (destructuring-bind
428     (start end file) loc
429     (declare (ignore end))
430     (values start file))))
431     (signal-compiler-condition
432     :original-condition condition
433     :severity :warning
434     :message (format nil "Undefined function referenced: ~S"
435     fname)
436     :location (make-location (list :file file)
437     (list :position (1+ pos)))))))))
438    
439 lgorrie 1.33 (defimplementation call-with-compilation-hooks (function)
440 trittweiler 1.126 (handler-bind ((warning #'handle-compiler-warning)
441     (compiler-note #'handle-compiler-warning)
442     (reader-error #'handle-compiler-warning))
443 lgorrie 1.33 (funcall function)))
444 heller 1.1
445 heller 1.124 (defimplementation swank-compile-file (input-file output-file
446 sboukarev 1.132 load-p external-format
447     &key policy)
448     (declare (ignore policy))
449 trittweiler 1.126 (handler-case
450     (with-compilation-hooks ()
451     (let ((*buffer-name* nil)
452     (*compile-filename* input-file))
453     (compile-file *compile-filename*
454     :output-file output-file
455     :load-after-compile load-p
456     :external-format external-format)))
457     (reader-error () (values nil nil t))))
458 heller 1.1
459 heller 1.46 (defun call-with-temp-file (fn)
460     (let ((tmpname (system:make-temp-file-name)))
461     (unwind-protect
462     (with-open-file (file tmpname :direction :output :if-exists :error)
463     (funcall fn file tmpname))
464     (delete-file tmpname))))
465    
466 heller 1.135 (defvar *temp-file-map* (make-hash-table :test #'equal)
467     "A mapping from tempfile names to Emacs buffer names.")
468    
469     (defun compile-from-temp-file (string buffer offset file)
470 heller 1.46 (call-with-temp-file
471     (lambda (stream filename)
472 heller 1.135 (let ((excl:*load-source-file-info* t)
473     (sys:*source-file-types* '(nil)) ; suppress .lisp extension
474     #+(version>= 8 2)
475     (compiler:save-source-level-debug-info-switch t)
476     #+(version>= 8 2)
477     (excl:*load-source-debug-info* t) ; NOTE: requires lldb
478     )
479 heller 1.46 (write-string string stream)
480     (finish-output stream)
481 heller 1.116 (multiple-value-bind (binary-filename warnings? failure?)
482 trittweiler 1.126 (excl:without-redefinition-warnings
483 heller 1.116 ;; Suppress Allegro's redefinition warnings; they are
484     ;; pointless when we are compiling via a temporary
485     ;; file.
486     (compile-file filename :load-after-compile t))
487     (declare (ignore warnings?))
488 heller 1.46 (when binary-filename
489 heller 1.135 (setf (gethash (pathname stream) *temp-file-map*)
490     (list buffer offset file))
491 heller 1.116 (delete-file binary-filename))
492 trittweiler 1.126 (not failure?))))))
493    
494     (defimplementation swank-compile-string (string &key buffer position filename
495     policy)
496     (declare (ignore policy))
497     (handler-case
498     (with-compilation-hooks ()
499     (let ((*buffer-name* buffer)
500     (*buffer-start-position* position)
501     (*buffer-string* string)
502     (*default-pathname-defaults*
503     (if filename
504     (merge-pathnames (pathname filename))
505     *default-pathname-defaults*)))
506 heller 1.135 (compile-from-temp-file string buffer position filename)))
507 heller 1.147 (reader-error () nil)))
508 heller 1.46
509 heller 1.8 ;;;; Definition Finding
510    
511 heller 1.137 (defun buffer-or-file (file file-fun buffer-fun)
512 heller 1.135 (let* ((probe (gethash file *temp-file-map*)))
513 heller 1.137 (cond (probe
514 heller 1.135 (destructuring-bind (buffer start file) probe
515     (declare (ignore file))
516 heller 1.137 (funcall buffer-fun buffer start)))
517     (t (funcall file-fun (namestring (truename file)))))))
518    
519     (defun buffer-or-file-location (file offset)
520     (buffer-or-file file
521     (lambda (filename)
522     (make-location `(:file ,filename)
523     `(:position ,(1+ offset))))
524     (lambda (buffer start)
525     (make-location `(:buffer ,buffer)
526     `(:offset ,start ,offset)))))
527 heller 1.135
528 heller 1.32 (defun fspec-primary-name (fspec)
529     (etypecase fspec
530 heller 1.62 (symbol fspec)
531     (list (fspec-primary-name (second fspec)))))
532 heller 1.135
533 mkoeppe 1.81 (defun find-definition-in-file (fspec type file top-level)
534     (let* ((part
535     (or (scm::find-definition-in-definition-group
536     fspec type (scm:section-file :file file)
537     :top-level top-level)
538     (scm::find-definition-in-definition-group
539     (fspec-primary-name fspec)
540     type (scm:section-file :file file)
541     :top-level top-level)))
542     (start (and part
543     (scm::source-part-start part)))
544 heller 1.60 (pos (if start
545 heller 1.114 (list :position (1+ start))
546 heller 1.62 (list :function-name (string (fspec-primary-name fspec))))))
547     (make-location (list :file (namestring (truename file)))
548     pos)))
549 heller 1.60
550 mkoeppe 1.81 (defun find-fspec-location (fspec type file top-level)
551 sboukarev 1.130 (handler-case
552     (etypecase file
553     (pathname
554 heller 1.135 (let ((probe (gethash file *temp-file-map*)))
555     (cond (probe
556     (destructuring-bind (buffer offset file) probe
557     (declare (ignore file))
558     (make-location `(:buffer ,buffer)
559     `(:offset ,offset 0))))
560     (t
561     (find-definition-in-file fspec type file top-level)))))
562 sboukarev 1.130 ((member :top-level)
563 heller 1.152 (make-error-location "Defined at toplevel: ~A"
564     (fspec->string fspec))))
565 sboukarev 1.130 (error (e)
566     (make-error-location "Error: ~A" e))))
567 lgorrie 1.49
568 heller 1.50 (defun fspec->string (fspec)
569 heller 1.135 (typecase fspec
570 heller 1.50 (symbol (let ((*package* (find-package :keyword)))
571     (prin1-to-string fspec)))
572     (list (format nil "(~A ~A)"
573     (prin1-to-string (first fspec))
574     (let ((*package* (find-package :keyword)))
575 heller 1.135 (prin1-to-string (second fspec)))))
576     (t (princ-to-string fspec))))
577 heller 1.21
578     (defun fspec-definition-locations (fspec)
579 mkoeppe 1.87 (cond
580 sboukarev 1.130 ((and (listp fspec)
581     (eql (car fspec) :top-level-form))
582 sboukarev 1.142 (destructuring-bind (top-level-form file &optional (position 0)) fspec
583 sboukarev 1.130 (declare (ignore top-level-form))
584 heller 1.137 `((,fspec
585     ,(buffer-or-file-location file position)))))
586 sboukarev 1.130 ((and (listp fspec) (eq (car fspec) :internal))
587     (destructuring-bind (_internal next _n) fspec
588     (declare (ignore _internal _n))
589     (fspec-definition-locations next)))
590     (t
591     (let ((defs (excl::find-source-file fspec)))
592     (when (and (null defs)
593     (listp fspec)
594     (string= (car fspec) '#:method))
595     ;; If methods are defined in a defgeneric form, the source location is
596     ;; recorded for the gf but not for the methods. Therefore fall back to
597     ;; the gf as the likely place of definition.
598     (setq defs (excl::find-source-file (second fspec))))
599     (if (null defs)
600     (list
601     (list fspec
602     (make-error-location "Unknown source location for ~A"
603     (fspec->string fspec))))
604 heller 1.133 (loop for (fspec type file top-level) in defs collect
605     (list (list type fspec)
606     (find-fspec-location fspec type file top-level))))))))
607 heller 1.21
608     (defimplementation find-definitions (symbol)
609     (fspec-definition-locations symbol))
610 heller 1.1
611 heller 1.8 ;;;; XREF
612    
613 heller 1.21 (defmacro defxref (name relation name1 name2)
614     `(defimplementation ,name (x)
615     (xref-result (xref:get-relation ,relation ,name1 ,name2))))
616    
617     (defxref who-calls :calls :wild x)
618 heller 1.70 (defxref calls-who :calls x :wild)
619 heller 1.21 (defxref who-references :uses :wild x)
620     (defxref who-binds :binds :wild x)
621     (defxref who-macroexpands :macro-calls :wild x)
622     (defxref who-sets :sets :wild x)
623    
624     (defun xref-result (fspecs)
625     (loop for fspec in fspecs
626     append (fspec-definition-locations fspec)))
627 heller 1.46
628     ;; list-callers implemented by groveling through all fbound symbols.
629     ;; Only symbols are considered. Functions in the constant pool are
630 heller 1.71 ;; searched recursively. Closure environments are ignored at the
631 heller 1.46 ;; moment (constants in methods are therefore not found).
632    
633     (defun map-function-constants (function fn depth)
634     "Call FN with the elements of FUNCTION's constant pool."
635     (do ((i 0 (1+ i))
636     (max (excl::function-constant-count function)))
637     ((= i max))
638     (let ((c (excl::function-constant function i)))
639     (cond ((and (functionp c)
640     (not (eq c function))
641     (plusp depth))
642     (map-function-constants c fn (1- depth)))
643     (t
644     (funcall fn c))))))
645    
646 heller 1.64 (defun in-constants-p (fun symbol)
647     (map-function-constants fun
648     (lambda (c)
649     (when (eq c symbol)
650     (return-from in-constants-p t)))
651     3))
652 heller 1.70
653 heller 1.46 (defun function-callers (name)
654     (let ((callers '()))
655     (do-all-symbols (sym)
656     (when (fboundp sym)
657     (let ((fn (fdefinition sym)))
658     (when (in-constants-p fn name)
659     (push sym callers)))))
660     callers))
661    
662     (defimplementation list-callers (name)
663     (xref-result (function-callers name)))
664 heller 1.4
665 heller 1.70 (defimplementation list-callees (name)
666     (let ((result '()))
667     (map-function-constants (fdefinition name)
668     (lambda (c)
669     (when (fboundp c)
670     (push c result)))
671     2)
672     (xref-result result)))
673    
674 mkoeppe 1.83 ;;;; Profiling
675    
676 heller 1.89 ;; Per-function profiling based on description in
677 heller 1.152 ;; http://www.franz.com/support/documentation/8.0/\
678     ;; doc/runtime-analyzer.htm#data-collection-control-2
679 heller 1.89
680     (defvar *profiled-functions* ())
681     (defvar *profile-depth* 0)
682    
683     (defmacro with-redirected-y-or-n-p (&body body)
684     ;; If the profiler is restarted when the data from the previous
685     ;; session is not reported yet, the user is warned via Y-OR-N-P.
686     ;; As the CL:Y-OR-N-P question is (for some reason) not directly
687     ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
688     ;; overruled.
689 sboukarev 1.144 `(let* ((pkg (find-package :common-lisp))
690 heller 1.89 (saved-pdl (excl::package-definition-lock pkg))
691     (saved-ynp (symbol-function 'cl:y-or-n-p)))
692     (setf (excl::package-definition-lock pkg) nil
693 sboukarev 1.144 (symbol-function 'cl:y-or-n-p)
694     (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
695 heller 1.89 (unwind-protect
696 sboukarev 1.144 (progn ,@body)
697 heller 1.89 (setf (symbol-function 'cl:y-or-n-p) saved-ynp
698     (excl::package-definition-lock pkg) saved-pdl))))
699    
700     (defun start-acl-profiler ()
701     (with-redirected-y-or-n-p
702     (prof:start-profiler :type :time :count t
703     :start-sampling-p nil :verbose nil)))
704     (defun acl-profiler-active-p ()
705     (not (eq (prof:profiler-status :verbose nil) :inactive)))
706    
707     (defun stop-acl-profiler ()
708     (prof:stop-profiler :verbose nil))
709    
710     (excl:def-fwrapper profile-fwrapper (&rest args)
711     ;; Ensures sampling is done during the execution of the function,
712     ;; taking into account recursion.
713     (declare (ignore args))
714     (cond ((zerop *profile-depth*)
715     (let ((*profile-depth* (1+ *profile-depth*)))
716     (prof:start-sampling)
717     (unwind-protect (excl:call-next-fwrapper)
718     (prof:stop-sampling))))
719     (t
720     (excl:call-next-fwrapper))))
721    
722     (defimplementation profile (fname)
723     (unless (acl-profiler-active-p)
724     (start-acl-profiler))
725     (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
726     (push fname *profiled-functions*))
727    
728     (defimplementation profiled-functions ()
729     *profiled-functions*)
730    
731     (defimplementation unprofile (fname)
732     (excl:funwrap fname 'profile-fwrapper)
733     (setq *profiled-functions* (remove fname *profiled-functions*)))
734    
735 mkoeppe 1.83 (defimplementation profile-report ()
736 heller 1.89 (prof:show-flat-profile :verbose nil)
737     (when *profiled-functions*
738     (start-acl-profiler)))
739    
740     (defimplementation profile-reset ()
741     (when (acl-profiler-active-p)
742     (stop-acl-profiler)
743     (start-acl-profiler))
744     "Reset profiling counters.")
745 mkoeppe 1.83
746 heller 1.18 ;;;; Inspecting
747    
748 heller 1.111 (excl:without-redefinition-warnings
749 heller 1.100 (defmethod emacs-inspect ((o t))
750 heller 1.111 (allegro-inspect o)))
751 heller 1.62
752 heller 1.100 (defmethod emacs-inspect ((o function))
753 heller 1.101 (allegro-inspect o))
754 heller 1.62
755 heller 1.100 (defmethod emacs-inspect ((o standard-object))
756 heller 1.101 (allegro-inspect o))
757 heller 1.82
758 heller 1.62 (defun allegro-inspect (o)
759     (loop for (d dd) on (inspect::inspect-ctl o)
760 heller 1.73 append (frob-allegro-field-def o d)
761     until (eq d dd)))
762 heller 1.62
763 heller 1.73 (defun frob-allegro-field-def (object def)
764 heller 1.62 (with-struct (inspect::field-def- name type access) def
765 heller 1.73 (ecase type
766 heller 1.79 ((:unsigned-word :unsigned-byte :unsigned-natural
767 heller 1.145 :unsigned-long :unsigned-half-long
768     :unsigned-3byte :unsigned-long32)
769 heller 1.73 (label-value-line name (inspect::component-ref-v object access type)))
770 heller 1.115 ((:lisp :value :func)
771 heller 1.73 (label-value-line name (inspect::component-ref object access)))
772     (:indirect
773     (destructuring-bind (prefix count ref set) access
774     (declare (ignore set prefix))
775     (loop for i below (funcall count object)
776     append (label-value-line (format nil "~A-~D" name i)
777     (funcall ref object i))))))))
778 mbaringer 1.55
779 heller 1.18 ;;;; Multithreading
780 heller 1.8
781 mbaringer 1.91 (defimplementation initialize-multiprocessing (continuation)
782     (mp:start-scheduler)
783     (funcall continuation))
784 heller 1.8
785 heller 1.10 (defimplementation spawn (fn &key name)
786 lgorrie 1.47 (mp:process-run-function name fn))
787 heller 1.8
788 heller 1.40 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
789     (defvar *thread-id-counter* 0)
790    
791     (defimplementation thread-id (thread)
792     (mp:with-process-lock (*id-lock*)
793     (or (getf (mp:process-property-list thread) 'id)
794     (setf (getf (mp:process-property-list thread) 'id)
795     (incf *thread-id-counter*)))))
796    
797     (defimplementation find-thread (id)
798     (find id mp:*all-processes*
799     :key (lambda (p) (getf (mp:process-property-list p) 'id))))
800    
801 heller 1.13 (defimplementation thread-name (thread)
802     (mp:process-name thread))
803 heller 1.8
804 heller 1.13 (defimplementation thread-status (thread)
805 sboukarev 1.140 (princ-to-string (mp:process-whostate thread)))
806    
807     (defimplementation thread-attributes (thread)
808     (list :priority (mp:process-priority thread)
809     :times-resumed (mp:process-times-resumed thread)))
810 heller 1.8
811 heller 1.10 (defimplementation make-lock (&key name)
812 heller 1.8 (mp:make-process-lock :name name))
813    
814 heller 1.10 (defimplementation call-with-lock-held (lock function)
815 heller 1.8 (mp:with-process-lock (lock) (funcall function)))
816 heller 1.12
817     (defimplementation current-thread ()
818     mp:*current-process*)
819    
820     (defimplementation all-threads ()
821 heller 1.13 (copy-list mp:*all-processes*))
822 heller 1.12
823     (defimplementation interrupt-thread (thread fn)
824     (mp:process-interrupt thread fn))
825    
826 heller 1.16 (defimplementation kill-thread (thread)
827     (mp:process-kill thread))
828    
829 heller 1.12 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
830    
831     (defstruct (mailbox (:conc-name mailbox.))
832 heller 1.107 (lock (mp:make-process-lock :name "process mailbox"))
833     (queue '() :type list)
834 heller 1.108 (gate (mp:make-gate nil)))
835 heller 1.12
836     (defun mailbox (thread)
837     "Return THREAD's mailbox."
838     (mp:with-process-lock (*mailbox-lock*)
839     (or (getf (mp:process-property-list thread) 'mailbox)
840     (setf (getf (mp:process-property-list thread) 'mailbox)
841     (make-mailbox)))))
842    
843     (defimplementation send (thread message)
844 heller 1.107 (let* ((mbox (mailbox thread)))
845     (mp:with-process-lock ((mailbox.lock mbox))
846     (setf (mailbox.queue mbox)
847     (nconc (mailbox.queue mbox) (list message)))
848     (mp:open-gate (mailbox.gate mbox)))))
849 heller 1.12
850 heller 1.110 (defimplementation receive-if (test &optional timeout)
851 heller 1.104 (let ((mbox (mailbox mp:*current-process*)))
852 heller 1.110 (assert (or (not timeout) (eq timeout t)))
853 heller 1.107 (loop
854     (check-slime-interrupts)
855     (mp:with-process-lock ((mailbox.lock mbox))
856     (let* ((q (mailbox.queue mbox))
857     (tail (member-if test q)))
858     (when tail
859     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
860     (return (car tail)))
861     (mp:close-gate (mailbox.gate mbox))))
862 heller 1.110 (when (eq timeout t) (return (values nil t)))
863     (mp:process-wait-with-timeout "receive-if" 0.5
864     #'mp:gate-open-p (mailbox.gate mbox)))))
865 heller 1.104
866 heller 1.150 (let ((alist '())
867     (lock (mp:make-process-lock :name "register-thread")))
868    
869     (defimplementation register-thread (name thread)
870     (declare (type symbol name))
871     (mp:with-process-lock (lock)
872     (etypecase thread
873     (null
874     (setf alist (delete name alist :key #'car)))
875     (mp:process
876     (let ((probe (assoc name alist)))
877     (cond (probe (setf (cdr probe) thread))
878     (t (setf alist (acons name thread alist))))))))
879     nil)
880    
881     (defimplementation find-registered (name)
882     (mp:with-process-lock (lock)
883     (cdr (assoc name alist)))))
884    
885 heller 1.123 (defimplementation set-default-initial-binding (var form)
886 heller 1.149 (push (cons var form)
887     #+(version>= 9 0)
888     excl:*required-thread-bindings*
889     #-(version>= 9 0)
890     excl::required-thread-bindings))
891 heller 1.123
892 mbaringer 1.27 (defimplementation quit-lisp ()
893     (excl:exit 0 :quiet t))
894 mbaringer 1.68
895 heller 1.69
896 mbaringer 1.68 ;;Trace implementations
897     ;;In Allegro 7.0, we have:
898     ;; (trace <name>)
899     ;; (trace ((method <name> <qualifier>? (<specializer>+))))
900     ;; (trace ((labels <name> <label-name>)))
901     ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
902     ;; <name> can be a normal name or a (setf name)
903    
904 heller 1.70 (defimplementation toggle-trace (spec)
905 lgorrie 1.72 (ecase (car spec)
906     ((setf)
907     (toggle-trace-aux spec))
908 heller 1.70 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
909 heller 1.71 ((setf :defmethod :labels :flet)
910 heller 1.70 (toggle-trace-aux (process-fspec-for-allegro spec)))
911 lgorrie 1.72 (:call
912 heller 1.70 (destructuring-bind (caller callee) (cdr spec)
913     (toggle-trace-aux callee
914     :inside (list (process-fspec-for-allegro caller)))))))
915    
916     (defun tracedp (fspec)
917 heller 1.71 (member fspec (eval '(trace)) :test #'equal))
918 heller 1.70
919     (defun toggle-trace-aux (fspec &rest args)
920     (cond ((tracedp fspec)
921     (eval `(untrace ,fspec))
922     (format nil "~S is now untraced." fspec))
923     (t
924     (eval `(trace (,fspec ,@args)))
925     (format nil "~S is now traced." fspec))))
926    
927     (defun toggle-trace-generic-function-methods (name)
928 mbaringer 1.68 (let ((methods (mop:generic-function-methods (fdefinition name))))
929 heller 1.70 (cond ((tracedp name)
930 mbaringer 1.68 (eval `(untrace ,name))
931     (dolist (method methods (format nil "~S is now untraced." name))
932     (excl:funtrace (mop:method-function method))))
933     (t
934 lgorrie 1.72 (eval `(trace (,name)))
935 heller 1.70 (dolist (method methods (format nil "~S is now traced." name))
936 mbaringer 1.68 (excl:ftrace (mop:method-function method)))))))
937    
938     (defun process-fspec-for-allegro (fspec)
939     (cond ((consp fspec)
940     (ecase (first fspec)
941 heller 1.71 ((setf) fspec)
942 mbaringer 1.68 ((:defun :defgeneric) (second fspec))
943     ((:defmethod) `(method ,@(rest fspec)))
944 heller 1.69 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
945     ,(third fspec)))
946     ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
947     ,(third fspec)))))
948 mbaringer 1.68 (t
949     fspec)))
950 heller 1.88
951    
952     ;;;; Weak hashtables
953    
954     (defimplementation make-weak-key-hash-table (&rest args)
955     (apply #'make-hash-table :weak-keys t args))
956    
957     (defimplementation make-weak-value-hash-table (&rest args)
958     (apply #'make-hash-table :values :weak args))
959 mkoeppe 1.93
960 alendvai 1.95 (defimplementation hash-table-weakness (hashtable)
961     (cond ((excl:hash-table-weak-keys hashtable) :key)
962     ((eq (excl:hash-table-values hashtable) :weak) :value)))
963    
964    
965 mkoeppe 1.93
966     ;;;; Character names
967    
968     (defimplementation character-completion-set (prefix matchp)
969     (loop for name being the hash-keys of excl::*name-to-char-table*
970     when (funcall matchp prefix name)
971     collect (string-capitalize name)))

  ViewVC Help
Powered by ViewVC 1.1.5