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

Diff of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.19.2.1 by heller, Tue Mar 9 08:57:25 2004 UTC revision 1.161 by sboukarev, Tue Apr 2 14:41:08 2013 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-  ;;;;                  -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
2  ;;;  ;;;
3  ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.  ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4  ;;;  ;;;
5  ;;; Created 2003, Helmut Eller  ;;; Created 2003
6  ;;;  ;;;
7  ;;; This code has been placed in the Public Domain.  All warranties  ;;; This code has been placed in the Public Domain.  All warranties
8  ;;; are disclaimed. This code was written for "Allegro CL Trial  ;;; are disclaimed.
 ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".  
9  ;;;  ;;;
10    
11    (in-package :swank-backend)
12    
13  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
14    (require :sock)    (require :sock)
15    (require :process))    (require :process)
16      #+(version>= 8 2)
17      (require 'lldb)
18      )
19    
20  (in-package :swank-backend)  (import-from :excl *gray-stream-symbols* :swank-backend)
21    
22    ;;; swank-mop
23    
24    (import-swank-mop-symbols :clos '(:slot-definition-documentation))
25    
26    (defun swank-mop:slot-definition-documentation (slot)
27      (documentation slot t))
28    
29  (import  
30   '(excl:fundamental-character-output-stream  ;;;; UTF8
    excl:stream-write-char  
    excl:stream-force-output  
    excl:fundamental-character-input-stream  
    excl:stream-read-char  
    excl:stream-listen  
    excl:stream-unread-char  
    excl:stream-clear-input  
    excl:stream-line-column  
    excl:stream-read-char-no-hang  
    ))  
31    
32    (define-symbol-macro utf8-ef
33        (load-time-value
34         (excl:crlf-base-ef (excl:find-external-format :utf-8))
35         t))
36    
37    (defimplementation string-to-utf8 (s)
38      (excl:string-to-octets s :external-format utf8-ef
39                             :null-terminate nil))
40    
41    (defimplementation utf8-to-string (u)
42      (excl:octets-to-string u :external-format utf8-ef))
43    
44    
45  ;;;; TCP Server  ;;;; TCP Server
46    
47  (defimplementation preferred-communication-style ()  (defimplementation preferred-communication-style ()
48     :spawn)    :spawn)
49    
50  (defimplementation create-socket (host port)  (defimplementation create-socket (host port &key backlog)
51    (socket:make-socket :connect :passive :local-port port    (socket:make-socket :connect :passive :local-port port
52                        :local-host host :reuse-address t))                        :local-host host :reuse-address t
53                          :backlog (or backlog 5)))
54    
55  (defimplementation local-port (socket)  (defimplementation local-port (socket)
56    (socket:local-port socket))    (socket:local-port socket))
# Line 43  Line 58 
58  (defimplementation close-socket (socket)  (defimplementation close-socket (socket)
59    (close socket))    (close socket))
60    
61  (defimplementation accept-connection (socket)  (defimplementation accept-connection (socket &key external-format buffering
62    (socket:accept-connection socket :wait t))                                               timeout)
63      (declare (ignore buffering timeout))
64  (defimplementation emacs-connected ())    (let ((s (socket:accept-connection socket :wait t)))
65        (when external-format
66          (setf (stream-external-format s) external-format))
67        s))
68    
69    (defimplementation socket-fd (stream)
70      (excl::stream-input-handle stream))
71    
72    (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    
88  ;;;; Unix signals  ;;;; Unix signals
89    
 (defimplementation call-without-interrupts (fn)  
   (excl:without-interrupts (funcall fn)))  
   
90  (defimplementation getpid ()  (defimplementation getpid ()
91    (excl::getpid))    (excl::getpid))
92    
93  (defimplementation lisp-implementation-type-name ()  (defimplementation lisp-implementation-type-name ()
94    "allegro")    "allegro")
95    
96    (defimplementation set-default-directory (directory)
97      (let* ((dir (namestring (truename (merge-pathnames directory)))))
98        (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
99        dir))
100    
101    (defimplementation default-directory ()
102      (namestring (excl:current-directory)))
103    
104  ;;;; Misc  ;;;; Misc
105    
106  (defimplementation arglist (symbol)  (defimplementation arglist (symbol)
107    (excl:arglist symbol))    (handler-case (excl:arglist symbol)
108        (simple-error () :not-available)))
109    
110    (defimplementation macroexpand-all (form)
111      #+(version>= 8 0)
112      (excl::walk-form form)
113      #-(version>= 8 0)
114      (excl::walk form))
115    
116  (defimplementation describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
117    (let ((result '()))    (let ((result '()))
# Line 82  Line 131 
131                    (doc 'class)))                    (doc 'class)))
132        result)))        result)))
133    
 (defimplementation macroexpand-all (form)  
   (excl::walk form))  
   
134  (defimplementation describe-definition (symbol namespace)  (defimplementation describe-definition (symbol namespace)
135    (ecase namespace    (ecase namespace
136      (:variable      (:variable
# Line 94  Line 140 
140      (:class      (:class
141       (describe (find-class symbol)))))       (describe (find-class symbol)))))
142    
143    (defimplementation type-specifier-p (symbol)
144      (or (ignore-errors
145           (subtypep nil symbol))
146          (not (eq (type-specifier-arglist symbol) :not-available))))
147    
148  ;;;; Debugger  ;;;; Debugger
149    
150  (defvar *sldb-topframe*)  (defvar *sldb-topframe*)
151    
152  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
153    (let ((*sldb-topframe* (excl::int-newest-frame))    (let ((*sldb-topframe* (find-topframe))
154          (excl::*break-hook* nil))          (excl::*break-hook* nil))
155      (funcall debugger-loop-fn)))      (funcall debugger-loop-fn)))
156    
157  (defun format-restarts-for-emacs ()  (defimplementation sldb-break-at-start (fname)
158    (loop for restart in *sldb-restarts*    ;; :print-before is kind of mis-used but we just want to stuff our
159          collect (list (princ-to-string (restart-name restart))    ;; break form somewhere. This does not work for setf, :before and
160                        (princ-to-string restart))))    ;; :after methods, which need special syntax in the trace call, see
161      ;; ACL's doc/debugging.htm chapter 10.
162      (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    (defun find-topframe ()
168      (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
169                                  (find-package :swank)))
170            (top-frame (excl::int-newest-frame (excl::current-thread))))
171        (loop for frame = top-frame then (next-frame frame)
172              for i from 0
173              while (and frame (< i 30))
174              when (eq (debugger:frame-name frame) magic-symbol)
175                return (next-frame frame)
176              finally (return top-frame))))
177    
178    (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  (defun nth-frame (index)  (defun nth-frame (index)
185    (do ((frame *sldb-topframe* (excl::int-next-older-frame frame))    (do ((frame *sldb-topframe* (next-frame frame))
186         (i index (1- i)))         (i index (1- i)))
187        ((zerop i) frame)))        ((zerop i) frame)))
188    
189  (defimplementation compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
190    (let ((end (or end most-positive-fixnum)))    (let ((end (or end most-positive-fixnum)))
191      (loop for f = (nth-frame start) then (excl::int-next-older-frame f)      (loop for f = (nth-frame start) then (next-frame f)
192            for i from start below end            for i from start below end
193            while f            while f collect f)))
           collect f)))  
194    
195  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
196    (debugger:output-frame stream frame :moderate))    (debugger:output-frame stream frame :moderate))
# Line 130  Line 202 
202                          :id 0                          :id 0
203                          :value (debugger:frame-var-value frame i)))))                          :value (debugger:frame-var-value frame i)))))
204    
205  (defimplementation frame-catch-tags (index)  (defimplementation frame-var-value (frame var)
206    (declare (ignore index))    (let ((frame (nth-frame frame)))
207    nil)      (debugger:frame-var-value frame var)))
208    
209  (defimplementation frame-source-location-for-emacs (index)  (defimplementation disassemble-frame (index)
210    (list :error (format nil "Cannot find source for frame: ~A"    (let ((frame (nth-frame index)))
211                         (nth-frame index))))      (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    
215    (defimplementation frame-source-location (index)
216      (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          (cond ((and pc
220                      #+(version>= 8 2)
221                      (pc-source-location fun pc)
222                      #-(version>= 8 2)
223                      (function-source-location fun)))
224                (t ; frames for unbound functions etc end up here
225                 (cadr (car (fspec-definition-locations
226                             (car (debugger:frame-expression frame))))))))))
227    
228    (defun function-source-location (fun)
229      (cadr (car (fspec-definition-locations
230                  (xref::object-to-function-name fun)))))
231    
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              (t
238               (let* ((code-loc (find-if (lambda (c)
239                                           (<= (- pc (sys::natural-width))
240                                               (let ((x (excl::ldb-code-pc c)))
241                                                 (or x -1))
242                                               pc))
243                                         debug-info)))
244                 (cond ((not code-loc)
245                        (ldb-code-to-src-loc (aref debug-info 0)))
246                       (t
247                        (ldb-code-to-src-loc code-loc))))))))
248    
249    #+(version>= 8 2)
250    (defun ldb-code-to-src-loc (code)
251      (declare (optimize debug))
252      (let* ((func (excl::ldb-code-func code))
253             (debug-info (excl::function-source-debug-info func))
254             (start (loop for i from (excl::ldb-code-index code) downto 0
255                          for bpt = (aref debug-info i)
256                          for start = (excl::ldb-code-start-char bpt)
257                          when start return start))
258             (src-file (excl:source-file func)))
259        (cond (start
260               (buffer-or-file-location src-file start))
261              (func
262               (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                      (path (if paths (longest-common-prefix paths) '()))
267                      (start 0))
268                 (buffer-or-file
269                  src-file
270                  (lambda (file)
271                    (make-location `(:file ,file)
272                                   `(:source-path (0 . ,path) ,start)))
273                  (lambda (buffer bstart)
274                    (make-location `(:buffer ,buffer)
275                                   `(:source-path (0 . ,path)
276                                                  ,(+ bstart start)))))))
277              (t
278               nil))))
279    
280    (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    
298  (defimplementation eval-in-frame (form frame-number)  (defimplementation eval-in-frame (form frame-number)
299    (debugger:eval-form-in-context    (let ((frame (nth-frame frame-number)))
300     form      ;; let-bind lexical variables
301     (debugger:environment-of-frame (nth-frame frame-number))))      (let ((vars (loop for i below (debugger:frame-number-vars frame)
302                          for name = (debugger:frame-var-name frame i)
303                          if (typep name '(and symbol (not null) (not keyword)))
304                          collect `(,name ',(debugger:frame-var-value frame i)))))
305          (debugger:eval-form-in-context
306           `(let* ,vars ,form)
307           (debugger:environment-of-frame frame)))))
308    
309    (defimplementation frame-package (frame-number)
310      (let* ((frame (nth-frame frame-number))
311             (exp (debugger:frame-expression frame)))
312        (typecase exp
313          ((cons symbol) (symbol-package (car exp)))
314          ((cons (cons (eql :internal) (cons symbol)))
315           (symbol-package (cadar exp))))))
316    
317  (defimplementation return-from-frame (frame-number form)  (defimplementation return-from-frame (frame-number form)
318    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
# Line 149  Line 320 
320        frame (debugger:eval-form-in-context        frame (debugger:eval-form-in-context
321               form               form
322               (debugger:environment-of-frame frame)))))               (debugger:environment-of-frame frame)))))
323    
324  ;;; XXX doens't work for frames with arguments  (defimplementation frame-restartable-p (frame)
325      (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    
331  (defimplementation restart-frame (frame-number)  (defimplementation restart-frame (frame-number)
332    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
333      (debugger:frame-retry frame (debugger:frame-function frame))))      (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    
338  ;;;; Compiler hooks  ;;;; Compiler hooks
339    
340  (defvar *buffer-name* nil)  (defvar *buffer-name* nil)
341  (defvar *buffer-start-position*)  (defvar *buffer-start-position*)
342  (defvar *buffer-string*)  (defvar *buffer-string*)
343  (defvar *compile-filename*)  (defvar *compile-filename* nil)
344    
345    (defun compiler-note-p (object)
346      (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
347    
348    (defun redefinition-p (condition)
349      (and (typep condition 'style-warning)
350           (every #'char-equal "redefin" (princ-to-string condition))))
351    
352    (defun compiler-undefined-functions-called-warning-p (object)
353      (typep object 'excl:compiler-undefined-functions-called-warning))
354    
355    (deftype compiler-note ()
356      `(satisfies compiler-note-p))
357    
358    (deftype redefinition ()
359      `(satisfies redefinition-p))
360    
361    (defun signal-compiler-condition (&rest args)
362      (apply #'signal 'compiler-condition args))
363    
364  (defun handle-compiler-warning (condition)  (defun handle-compiler-warning (condition)
365      (declare (optimize (debug 3) (speed 0) (space 0)))
366      (cond ((and (not *buffer-name*)
367                  (compiler-undefined-functions-called-warning-p condition))
368             (handle-undefined-functions-warning condition))
369            ((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            (t
377             (signal-compiler-condition
378              :original-condition condition
379              :severity (etypecase condition
380                          (redefinition  :redefinition)
381                          (style-warning :style-warning)
382                          (warning       :warning)
383                          (compiler-note :note)
384                          (reader-error  :read-error)
385                          (error         :error))
386              :message (format nil "~A" condition)
387              :location (if (typep condition 'reader-error)
388                            (location-for-reader-error condition)
389                            (location-for-warning condition))))))
390    
391    (defun location-for-warning (condition)
392    (let ((loc (getf (slot-value condition 'excl::plist) :loc)))    (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
393      (signal (make-condition      (cond (*buffer-name*
394               'compiler-condition             (make-location
395               :original-condition condition              (list :buffer *buffer-name*)
396               :severity :warning              (list :offset *buffer-start-position* 0)))
397               :message (format nil "~A" condition)            (loc
398               :location (cond (*buffer-name*             (destructuring-bind (file . pos) loc
399                                (make-location               (let ((start (cond ((consp pos) ; 8.2 and newer
400                                 (list :buffer *buffer-name*)                                   (car pos))
401                                 (list :position *buffer-start-position*)))                                  (t pos))))
402                               (loc                 (make-location
403                                (destructuring-bind (file . pos) loc                  (list :file (namestring (truename file)))
404                                  (make-location                  (list :position (1+ start))))))
405                                   (list :file (namestring (truename file)))            (t
406                                   (list :position (1+ pos)))))             (make-error-location "No error location available.")))))
407                               (t  
408                                (make-location  (defun location-for-reader-error (condition)
409                                 (list :file *compile-filename*)    (let ((pos  (car (last (slot-value condition 'excl::format-arguments))))
410                                 (list :position 1))))))))          (file (pathname (stream-error-stream condition))))
411        (if (integerp pos)
412  (defimplementation swank-compile-file (*compile-filename* load-p)          (if *buffer-name*
413    (handler-bind ((warning #'handle-compiler-warning))              (make-location `(:buffer ,*buffer-name*)
414      (let ((*buffer-name* nil))                             `(:offset ,*buffer-start-position* ,pos))
415        (compile-file *compile-filename* :load-after-compile load-p))))              (make-location `(:file ,(namestring (truename file)))
416                               `(:position ,pos)))
417  (defimplementation swank-compile-string (string &key buffer position)          (make-error-location "No error location available."))))
418    (handler-bind ((warning #'handle-compiler-warning))  
419      (let ((*buffer-name* buffer)  ;; TODO: report it as a bug to Franz that the condition's plist
420            (*buffer-start-position* position)  ;; slot contains (:loc nil).
421            (*buffer-string* string))  (defun handle-undefined-functions-warning (condition)
422        (funcall (compile nil (read-from-string    (let ((fargs (slot-value condition 'excl::format-arguments)))
423                               (format nil "(CL:LAMBDA () ~A)" string)))))))      (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    (defimplementation call-with-compilation-hooks (function)
440      (handler-bind ((warning       #'handle-compiler-warning)
441                     (compiler-note #'handle-compiler-warning)
442                     (reader-error  #'handle-compiler-warning))
443        (funcall function)))
444    
445    (defimplementation swank-compile-file (input-file output-file
446                                           load-p external-format
447                                           &key policy)
448      (declare (ignore policy))
449      (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    
459    (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    (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      (call-with-temp-file
471       (lambda (stream filename)
472         (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           (write-string string stream)
480           (finish-output stream)
481           (multiple-value-bind (binary-filename warnings? failure?)
482               (excl:without-redefinition-warnings
483                 ;; 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             (when binary-filename
489               (setf (gethash (pathname stream) *temp-file-map*)
490                     (list buffer offset file))
491               (delete-file binary-filename))
492             (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              (compile-from-temp-file string buffer position filename)))
507        (reader-error () nil)))
508    
509  ;;;; Definition Finding  ;;;; Definition Finding
510    
511  (defun find-fspec-location (fspec type)  (defun buffer-or-file (file file-fun buffer-fun)
512    (let ((file (excl::fspec-pathname fspec type)))    (let* ((probe (gethash file *temp-file-map*)))
513      (etypecase file      (cond (probe
514        (pathname             (destructuring-bind (buffer start file) probe
515         (let ((start (scm:find-definition-in-file fspec type file)))               (declare (ignore file))
516           (make-location (list :file (namestring (truename file)))               (funcall buffer-fun buffer start)))
517                          (if start            (t (funcall file-fun (namestring (truename file)))))))
518                              (list :position (1+ start))  
519                              (list :function-name (string fspec))))))  (defun buffer-or-file-location (file offset)
520        ((member :top-level)    (buffer-or-file file
521         (list :error (format nil "Defined at toplevel: ~A" fspec)))                    (lambda (filename)
522        (null                      (make-location `(:file ,filename)
523         (list :error (format nil "Unkown source location for ~A" fspec))))))                                     `(:position ,(1+ offset))))
524                      (lambda (buffer start)
525  (defun fspec-source-locations (fspec)                      (make-location `(:buffer ,buffer)
526    (let ((defs (excl::find-multiple-definitions fspec)))                                     `(:offset ,start ,offset)))))
527      (loop for (fspec type) in defs  
528            collect (list fspec (find-fspec-location fspec type)))))  (defun fspec-primary-name (fspec)
529      (etypecase fspec
530        (symbol fspec)
531        (list (fspec-primary-name (second fspec)))))
532    
533    (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             (pos (if start
545                      (list :position (1+ start))
546                      (list :function-name (string (fspec-primary-name fspec))))))
547        (make-location (list :file (namestring (truename file)))
548                       pos)))
549    
550    (defun find-fspec-location (fspec type file top-level)
551      (handler-case
552          (etypecase file
553            (pathname
554             (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            ((member :top-level)
563             (make-error-location "Defined at toplevel: ~A"
564                                  (fspec->string fspec))))
565        (error (e)
566          (make-error-location "Error: ~A" e))))
567    
568    (defun fspec->string (fspec)
569      (typecase fspec
570        (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                        (prin1-to-string (second fspec)))))
576        (t (princ-to-string fspec))))
577    
578    (defun fspec-definition-locations (fspec)
579      (cond
580        ((and (listp fspec)
581              (eql (car fspec) :top-level-form))
582         (destructuring-bind (top-level-form file &optional (position 0)) fspec
583           (declare (ignore top-level-form))
584           `((,fspec
585              ,(buffer-or-file-location file position)))))
586        ((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               (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    
608  (defimplementation find-definitions (symbol)  (defimplementation find-definitions (symbol)
609    (fspec-source-locations symbol))    (fspec-definition-locations symbol))
610    
611  ;;;; XREF  ;;;; XREF
612    
613  (defun xrefs (fspecs)  (defmacro defxref (name relation name1 name2)
614    (loop for fspec in fspecs    `(defimplementation ,name (x)
615          nconc (loop for (ref location) in (fspec-source-locations fspec)      (xref-result (xref:get-relation ,relation ,name1 ,name2))))
616                      collect (list ref location))))  
617    (defxref who-calls        :calls       :wild x)
618  (defimplementation who-calls (name)  (defxref calls-who        :calls       x :wild)
619    (xrefs (xref:get-relation :calls :wild name)))  (defxref who-references   :uses        :wild x)
620    (defxref who-binds        :binds       :wild x)
621  (defimplementation who-references (name)  (defxref who-macroexpands :macro-calls :wild x)
622    (xrefs (xref:get-relation :uses :wild name)))  (defxref who-sets         :sets        :wild x)
623    
624  (defimplementation who-binds (name)  (defun xref-result (fspecs)
625    (xrefs (xref:get-relation :binds :wild name)))    (loop for fspec in fspecs
626            append (fspec-definition-locations fspec)))
627    
628  (defimplementation who-macroexpands (name)  ;; list-callers implemented by groveling through all fbound symbols.
629    (xrefs (xref:get-relation :macro-calls :wild name)))  ;; Only symbols are considered.  Functions in the constant pool are
630    ;; searched recursively.  Closure environments are ignored at the
631    ;; 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    (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    
653    (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 who-sets (name)  (defimplementation list-callers (name)
663    (xrefs (xref:get-relation :sets :wild name)))    (xref-result (function-callers name)))
664    
665  (defimplementation list-callees (name)  (defimplementation list-callees (name)
666    (xrefs (xref:get-relation :calls name :wild)))    (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    ;;;; Profiling
675    
676    ;; Per-function profiling based on description in
677    ;;  http://www.franz.com/support/documentation/8.0/\
678    ;;  doc/runtime-analyzer.htm#data-collection-control-2
679    
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      `(let* ((pkg       (find-package :common-lisp))
690              (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               (symbol-function 'cl:y-or-n-p)
694               (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
695         (unwind-protect
696              (progn ,@body)
697           (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    (defimplementation profile-report ()
736      (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    
746  ;;;; Inspecting  ;;;; Inspecting
747    
748  (defmethod inspected-parts (o)  (excl:without-redefinition-warnings
749    (let* ((class (class-of o))  (defmethod emacs-inspect ((o t))
750           (slots (clos:class-slots class)))    (allegro-inspect o)))
751      (values (format nil "~A~%   is a ~A" o class)  
752              (mapcar (lambda (slot)  (defmethod emacs-inspect ((o function))
753                        (let ((name (clos:slot-definition-name slot)))    (allegro-inspect o))
754                          (cons (princ-to-string name)  
755                                (slot-value o name))))  (defmethod emacs-inspect ((o standard-object))
756                      slots))))    (allegro-inspect o))
757    
758    (defun allegro-inspect (o)
759      (loop for (d dd) on (inspect::inspect-ctl o)
760            append (frob-allegro-field-def o d)
761            until (eq d dd)))
762    
763    (defun frob-allegro-field-def (object def)
764      (with-struct (inspect::field-def- name type access) def
765        (ecase type
766          ((:unsigned-word :unsigned-byte :unsigned-natural
767                           :unsigned-long :unsigned-half-long
768                           :unsigned-3byte :unsigned-long32)
769           (label-value-line name (inspect::component-ref-v object access type)))
770          ((:lisp :value :func)
771           (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    
779  ;;;; Multithreading  ;;;; Multithreading
780    
781  (defimplementation startup-multiprocessing ()  (defimplementation initialize-multiprocessing (continuation)
782    (mp:start-scheduler))    (mp:start-scheduler)
783      (funcall continuation))
784    
785  (defimplementation spawn (fn &key name)  (defimplementation spawn (fn &key name)
786    (mp:process-run-function name fn))    (mp:process-run-function name fn))
787    
788    (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  (defimplementation thread-name (thread)  (defimplementation thread-name (thread)
802    (mp:process-name thread))    (mp:process-name thread))
803    
804  (defimplementation thread-status (thread)  (defimplementation thread-status (thread)
805    (format nil "~A ~D" (mp:process-whostate thread)    (princ-to-string (mp:process-whostate thread)))
806            (mp:process-priority thread)))  
807    (defimplementation thread-attributes (thread)
808      (list :priority (mp:process-priority thread)
809            :times-resumed (mp:process-times-resumed thread)))
810    
811  (defimplementation make-lock (&key name)  (defimplementation make-lock (&key name)
812    (mp:make-process-lock :name name))    (mp:make-process-lock :name name))
# Line 293  Line 829 
829  (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))  (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
830    
831  (defstruct (mailbox (:conc-name mailbox.))  (defstruct (mailbox (:conc-name mailbox.))
832    (mutex (mp:make-process-lock :name "process mailbox"))    (lock (mp:make-process-lock :name "process mailbox"))
833    (queue '() :type list))    (queue '() :type list)
834      (gate (mp:make-gate nil)))
835    
836  (defun mailbox (thread)  (defun mailbox (thread)
837    "Return THREAD's mailbox."    "Return THREAD's mailbox."
# Line 304  Line 841 
841                (make-mailbox)))))                (make-mailbox)))))
842    
843  (defimplementation send (thread message)  (defimplementation send (thread message)
844    (let* ((mbox (mailbox thread))    (let* ((mbox (mailbox thread)))
845           (mutex (mailbox.mutex mbox)))      (mp:with-process-lock ((mailbox.lock mbox))
846      (mp:with-process-lock (mutex)        (setf (mailbox.queue mbox)
847        (setf (mailbox.queue mbox)              (nconc (mailbox.queue mbox) (list message)))
848              (nconc (mailbox.queue mbox) (list message))))))        (mp:open-gate (mailbox.gate mbox)))))
849    
850  (defimplementation receive ()  (defimplementation receive-if (test &optional timeout)
851    (let* ((mbox (mailbox mp:*current-process*))    (let ((mbox (mailbox mp:*current-process*)))
852           (mutex (mailbox.mutex mbox)))      (assert (or (not timeout) (eq timeout t)))
853      (mp:process-wait "receive" #'mailbox.queue mbox)      (loop
854      (mp:with-process-lock (mutex)       (check-slime-interrupts)
855        (pop (mailbox.queue mbox)))))       (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         (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    
866    (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    (defimplementation set-default-initial-binding (var form)
886      (push (cons var form)
887            #+(version>= 9 0)
888            excl:*required-thread-bindings*
889            #-(version>= 9 0)
890            excl::required-thread-bindings))
891    
892    (defimplementation quit-lisp ()
893      (excl:exit 0 :quiet t))
894    
895    
896    ;;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    (defimplementation toggle-trace (spec)
905      (ecase (car spec)
906        ((setf)
907         (toggle-trace-aux spec))
908        (:defgeneric (toggle-trace-generic-function-methods (second spec)))
909        ((setf :defmethod :labels :flet)
910         (toggle-trace-aux (process-fspec-for-allegro spec)))
911        (:call
912         (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      (member fspec (eval '(trace)) :test #'equal))
918    
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      (let ((methods (mop:generic-function-methods (fdefinition name))))
929        (cond ((tracedp name)
930               (eval `(untrace ,name))
931               (dolist (method methods (format nil "~S is now untraced." name))
932                 (excl:funtrace (mop:method-function method))))
933              (t
934               (eval `(trace (,name)))
935               (dolist (method methods (format nil "~S is now traced." name))
936                 (excl:ftrace (mop:method-function method)))))))
937    
938    (defun process-fspec-for-allegro (fspec)
939      (cond ((consp fspec)
940             (ecase (first fspec)
941               ((setf) fspec)
942               ((:defun :defgeneric) (second fspec))
943               ((:defmethod) `(method ,@(rest fspec)))
944               ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
945                             ,(third fspec)))
946               ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
947                           ,(third fspec)))))
948            (t
949             fspec)))
950    
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    
960    (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    
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)))

Legend:
Removed from v.1.19.2.1  
changed lines
  Added in v.1.161

  ViewVC Help
Powered by ViewVC 1.1.5