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

Diff of /slime/swank-lispworks.lisp

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

revision 1.13 by heller, Tue Jan 13 18:20:04 2004 UTC revision 1.128 by heller, Sat Jan 10 12:25:16 2009 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  ;;; -*- indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.  ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
4  ;;;  ;;;
# Line 7  Line 7 
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.  ;;; are disclaimed.
9  ;;;  ;;;
 ;;;   $Id$  
 ;;;  
10    
11  (in-package :swank)  (in-package :swank-backend)
12    
13  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
14    (require "comm"))    (require "comm")
15      (import-from :stream *gray-stream-symbols* :swank-backend))
 (import  
  '(stream:fundamental-character-output-stream  
    stream:stream-write-char  
    stream:stream-force-output  
    stream:fundamental-character-input-stream  
    stream:stream-read-char  
    stream:stream-listen  
    stream:stream-unread-char  
    stream:stream-clear-input  
    stream:stream-line-column  
    ))  
   
 (defun without-interrupts* (body)  
   (lispworks:without-interrupts (funcall body)))  
16    
17  (defconstant +sigint+ 2)  (import-swank-mop-symbols :clos '(:slot-definition-documentation
18                                      :eql-specializer
19                                      :eql-specializer-object
20                                      :compute-applicable-methods-using-classes))
21    
22    (defun swank-mop:slot-definition-documentation (slot)
23      (documentation slot t))
24    
25    (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
26      (clos::compute-applicable-methods-from-classes gf classes))
27    
28    ;; lispworks doesn't have the eql-specializer class, it represents
29    ;; them as a list of `(EQL ,OBJECT)
30    (deftype swank-mop:eql-specializer () 'cons)
31    
32    (defun swank-mop:eql-specializer-object (eql-spec)
33      (second eql-spec))
34    
35    (eval-when (:compile-toplevel :execute :load-toplevel)
36      (defvar *original-defimplementation* (macro-function 'defimplementation))
37      (defmacro defimplementation (&whole whole name args &body body
38                                   &environment env)
39        (declare (ignore args body))
40        `(progn
41           (dspec:record-definition '(defun ,name) (dspec:location)
42                                    :check-redefinition-p nil)
43           ,(funcall *original-defimplementation* whole env))))
44    
45  ;;; TCP server  ;;; TCP server
46    
47    (defimplementation preferred-communication-style ()
48      :spawn)
49    
50  (defun socket-fd (socket)  (defun socket-fd (socket)
51    (etypecase socket    (etypecase socket
52      (fixnum socket)      (fixnum socket)
53      (comm:socket-stream (comm:socket-stream-socket socket))))      (comm:socket-stream (comm:socket-stream-socket socket))))
54    
55  (defmethod create-socket (port)  (defimplementation create-socket (host port)
56    (multiple-value-bind (socket where errno)    (multiple-value-bind (socket where errno)
57        (comm::create-tcp-socket-for-service port :address "localhost")        #-(or lispworks4.1 (and macosx lispworks4.3))
58          (comm::create-tcp-socket-for-service port :address host)
59          #+(or lispworks4.1 (and macosx lispworks4.3))
60          (comm::create-tcp-socket-for-service port)
61      (cond (socket socket)      (cond (socket socket)
62            (t (error 'network-error "asdf ~A")            (t (error 'network-error
63                :format-control "~A failed: ~A (~D)"                :format-control "~A failed: ~A (~D)"
64                :format-arguments (list where                :format-arguments (list where
65                                        (list #+unix (lw:get-unix-error errno))                                        (list #+unix (lw:get-unix-error errno))
66                                        errno)))))                                        errno))))))
67    
68  (defmethod local-port (socket)  (defimplementation local-port (socket)
69    (nth-value 1 (comm:get-socket-address (socket-fd socket))))    (nth-value 1 (comm:get-socket-address (socket-fd socket))))
70    
71  (defmethod close-socket (socket)  (defimplementation close-socket (socket)
72    (comm::close-socket (socket-fd socket)))    (comm::close-socket (socket-fd socket)))
73    
74  (defmethod accept-connection (socket)  (defimplementation accept-connection (socket
75    (let ((fd (comm::get-fd-from-socket socket)))                                        &key external-format buffering timeout)
76      (declare (ignore buffering))
77      (let* ((fd (comm::get-fd-from-socket socket)))
78      (assert (/= fd -1))      (assert (/= fd -1))
79      (make-instance 'comm:socket-stream :socket fd :direction :io      (assert (valid-external-format-p external-format))
80                     :element-type 'base-char)))      (cond ((member (first external-format) '(:latin-1 :ascii))
81               (make-instance 'comm:socket-stream
82  (defmethod spawn (fn &key name)                            :socket fd
83    (mp:process-run-function name () fn))                            :direction :io
84                              :read-timeout timeout
85                              :element-type 'base-char))
86              (t
87               (make-flexi-stream
88                (make-instance 'comm:socket-stream
89                               :socket fd
90                               :direction :io
91                               :read-timeout timeout
92                               :element-type '(unsigned-byte 8))
93                external-format)))))
94    
95    (defun make-flexi-stream (stream external-format)
96      (unless (member :flexi-streams *features*)
97        (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
98               external-format))
99      (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
100               stream
101               :external-format
102               (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
103                      external-format)))
104    
105    ;;; Coding Systems
106    
107    (defun valid-external-format-p (external-format)
108      (member external-format *external-format-to-coding-system*
109              :test #'equal :key #'car))
110    
111    (defvar *external-format-to-coding-system*
112      '(((:latin-1 :eol-style :lf)
113         "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
114        ((:latin-1)
115         "latin-1" "iso-latin-1" "iso-8859-1")
116        ((:utf-8) "utf-8")
117        ((:utf-8 :eol-style :lf) "utf-8-unix")
118        ((:euc-jp) "euc-jp")
119        ((:euc-jp :eol-style :lf) "euc-jp-unix")
120        ((:ascii) "us-ascii")
121        ((:ascii :eol-style :lf) "us-ascii-unix")))
122    
123    (defimplementation find-external-format (coding-system)
124      (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
125                      *external-format-to-coding-system*)))
126    
127    ;;; Unix signals
128    
129    (defun sigint-handler ()
130      (with-simple-restart  (continue "Continue from SIGINT handler.")
131        (invoke-debugger "SIGINT")))
132    
133    (defun make-sigint-handler (process)
134      (lambda (&rest args)
135        (declare (ignore args))
136        (mp:process-interrupt process #'sigint-handler)))
137    
138  (defmethod emacs-connected ()  (defun set-sigint-handler ()
139    ;; Set SIGINT handler on Swank request handler thread.    ;; Set SIGINT handler on Swank request handler thread.
140    (sys:set-signal-handler +sigint+ #'sigint-handler))    #-win32
141      (sys::set-signal-handler +sigint+
142                               (make-sigint-handler mp:*current-process*)))
143    
144    #-win32
145    (defimplementation install-sigint-handler (handler)
146      (sys::set-signal-handler +sigint+
147                               (let ((self mp:*current-process*))
148                                 (lambda (&rest args)
149                                   (declare (ignore args))
150                                   (mp:process-interrupt self handler)))))
151    
152    (defimplementation call-without-interrupts (fn)
153      (lw:without-interrupts (funcall fn)))
154    
155    (defimplementation getpid ()
156      #+win32 (win32:get-current-process-id)
157      #-win32 (system::getpid))
158    
159    (defimplementation lisp-implementation-type-name ()
160      "lispworks")
161    
162    (defimplementation set-default-directory (directory)
163      (namestring (hcl:change-directory directory)))
164    
165    ;;;; Documentation
166    
167    (defimplementation arglist (symbol-or-function)
168      (let ((arglist (lw:function-lambda-list symbol-or-function)))
169        (etypecase arglist
170          ((member :dont-know)
171           :not-available)
172          (list
173           arglist))))
174    
175  (defun sigint-handler (&rest args)  (defimplementation function-name (function)
176    (declare (ignore args))    (nth-value 2 (function-lambda-expression function)))
   (invoke-debugger "SIGINT"))  
   
 ;;;  
177    
178  (defslimefun getpid ()  (defimplementation macroexpand-all (form)
   "Return the process ID of this superior Lisp."  
   (system::getpid))  
   
 (defmethod arglist-string (fname)  
   "Return the lambda list for function FNAME as a string."  
   (let ((*print-case* :downcase))  
     (multiple-value-bind (function condition)  
         (ignore-errors (values  
                         (find-symbol-designator fname *buffer-package*)))  
       (when condition  
         (return-from arglist-string (format nil "(-- ~A)" condition)))  
       (let ((arglist (and (fboundp function)  
                           (lispworks:function-lambda-list function))))  
         (if arglist  
             (princ-to-string arglist)  
             "(-- <Unknown-Function>)")))))  
   
 (defmethod macroexpand-all (form)  
179    (walker:walk-form form))    (walker:walk-form form))
180    
181  (defmethod describe-symbol-for-emacs (symbol)  (defun generic-function-p (object)
182      (typep object 'generic-function))
183    
184    (defimplementation describe-symbol-for-emacs (symbol)
185    "Return a plist describing SYMBOL.    "Return a plist describing SYMBOL.
186  Return NIL if the symbol is unbound."  Return NIL if the symbol is unbound."
187    (let ((result '()))    (let ((result '()))
# Line 103  Return NIL if the symbol is unbound." Line 189  Return NIL if the symbol is unbound."
189                 (let ((pos (position #\newline string)))                 (let ((pos (position #\newline string)))
190                   (if (null pos) string (subseq string 0 pos))))                   (if (null pos) string (subseq string 0 pos))))
191               (doc (kind &optional (sym symbol))               (doc (kind &optional (sym symbol))
192                 (let ((string (documentation sym kind)))                 (let ((string (or (documentation sym kind))))
193                   (if string                   (if string
194                       (first-line string)                       (first-line string)
195                       :not-documented)))                       :not-documented)))
# Line 114  Return NIL if the symbol is unbound." Line 200  Return NIL if the symbol is unbound."
200         :variable (when (boundp symbol)         :variable (when (boundp symbol)
201                     (doc 'variable)))                     (doc 'variable)))
202        (maybe-push        (maybe-push
203         :function (if (fboundp symbol)         :generic-function (if (and (fboundp symbol)
204                                      (generic-function-p (fdefinition symbol)))
205                                 (doc 'function)))
206          (maybe-push
207           :function (if (and (fboundp symbol)
208                              (not (generic-function-p (fdefinition symbol))))
209                       (doc 'function)))                       (doc 'function)))
210        (maybe-push        (maybe-push
211           :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
212                   (if (fboundp setf-name)
213                       (doc 'setf))))
214          (maybe-push
215         :class (if (find-class symbol nil)         :class (if (find-class symbol nil)
216                    (doc 'class)))                    (doc 'class)))
217        (if result        result)))
           (list* :designator (to-string symbol) result)))))  
218    
219  (defslimefun describe-function (symbol-name)  (defimplementation describe-definition (symbol type)
220    (with-output-to-string (*standard-output*)    (ecase type
221      (let ((sym (from-string symbol-name)))      (:variable (describe-symbol symbol))
222        (cond ((fboundp sym)      (:class (describe (find-class symbol)))
223               (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"      ((:function :generic-function) (describe-function symbol))
224                       (string-downcase sym)      (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
225                       (mapcar #'string-upcase  
226                               (lispworks:function-lambda-list sym))  (defun describe-function (symbol)
227                       (documentation sym 'function))    (cond ((fboundp symbol)
228               (describe (symbol-function sym)))           (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
229              (t (format t "~S is not fbound" sym))))))                   symbol
230                     (lispworks:function-lambda-list symbol)
231                     (documentation symbol 'function))
232             (describe (fdefinition symbol)))
233            (t (format t "~S is not fbound" symbol))))
234    
235  #+(or)  (defun describe-symbol (sym)
 (defmethod describe-object ((sym symbol) *standard-output*)  
236    (format t "~A is a symbol in package ~A." sym (symbol-package sym))    (format t "~A is a symbol in package ~A." sym (symbol-package sym))
237    (when (boundp sym)    (when (boundp sym)
238      (format t "~%~%Value: ~A" (symbol-value sym)))      (format t "~%~%Value: ~A" (symbol-value sym)))
# Line 143  Return NIL if the symbol is unbound." Line 240  Return NIL if the symbol is unbound."
240      (when doc      (when doc
241        (format t "~%~%Variable documentation:~%~A"  doc)))        (format t "~%~%Variable documentation:~%~A"  doc)))
242    (when (fboundp sym)    (when (fboundp sym)
243      (format t "~%~%(~A~{ ~A~})"      (describe-function sym)))
             (string-downcase sym)  
             (mapcar #'string-upcase  
                     (lispworks:function-lambda-list sym))))  
   (let ((doc (documentation sym 'function)))  
     (when doc (format t "~%~%~A~%"  doc))))  
244    
245  ;;; Debugging  ;;; Debugging
246    
247  (defvar *sldb-restarts*)  (defclass slime-env (env:environment)
248      ((debugger-hook :initarg :debugger-hoook)))
249    
250  (defslimefun sldb-abort ()  (defun slime-env (hook io-bindings)
251    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (make-instance 'slime-env :name "SLIME Environment"
252                     :io-bindings io-bindings
253                     :debugger-hoook hook))
254    
255    (defmethod env-internals:environment-display-notifier
256        ((env slime-env) &key restarts condition)
257      (declare (ignore restarts condition))
258      (funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
259      ;;  nil
260      )
261    
262    (defmethod env-internals:environment-display-debugger ((env slime-env))
263      *debug-io*)
264    
265    (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
266      (apply (swank-sym :y-or-n-p-in-emacs) msg args))
267    
268    (defimplementation call-with-debugger-hook (hook fun)
269      (let ((*debugger-hook* hook))
270        (env:with-environment ((slime-env hook '()))
271          (funcall fun))))
272    
273    (defimplementation install-debugger-globally (function)
274      (setq *debugger-hook* function)
275      (setf (env:environment) (slime-env function '())))
276    
277  (defmethod call-with-debugging-environment (fn)  (defvar *sldb-top-frame*)
   (dbg::with-debugger-stack ()  
     (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*)))  
       (funcall fn))))  
   
 (defun format-restarts-for-emacs ()  
   (loop for restart in *sldb-restarts*  
         collect (list (princ-to-string (restart-name restart))  
                       (princ-to-string restart))))  
278    
279  (defun interesting-frame-p (frame)  (defun interesting-frame-p (frame)
280    (or (dbg::call-frame-p frame)    (cond ((or (dbg::call-frame-p frame)
281        (dbg::catch-frame-p frame)))               (dbg::derived-call-frame-p frame)
282                 (dbg::foreign-frame-p frame)
283                 (dbg::interpreted-call-frame-p frame))
284             t)
285            ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
286            ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
287            ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
288            ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
289            ((dbg::open-frame-p frame) dbg:*print-open-frames*)
290            (t nil)))
291    
292    (defun nth-next-frame (frame n)
293      "Unwind FRAME N times."
294      (do ((frame frame (dbg::frame-next frame))
295           (i n (if (interesting-frame-p frame) (1- i) i)))
296          ((or (not frame)
297               (and (interesting-frame-p frame) (zerop i)))
298           frame)))
299    
300  (defun nth-frame (index)  (defun nth-frame (index)
301    (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)    (nth-next-frame *sldb-top-frame* index))
302                (dbg::frame-next frame))  
303         (i index (if (interesting-frame-p frame) (1- i) i)))  (defun find-top-frame ()
304        ((and (interesting-frame-p frame) (zerop i)) frame)    "Return the most suitable top-frame for the debugger."
305      (assert frame)))    (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
306                      (nth-next-frame frame 1)))
307              ((or (null frame)             ; no frame found!
308                   (and (dbg::call-frame-p frame)
309                        (eq (dbg::call-frame-function-name frame)
310                            'invoke-debugger)))
311               (nth-next-frame frame 1)))
312          ;; if we can't find a invoke-debugger frame, take any old frame at the top
313          (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))
314    
315    (defimplementation call-with-debugging-environment (fn)
316      (dbg::with-debugger-stack ()
317        (let ((*sldb-top-frame* (find-top-frame)))
318          (funcall fn))))
319    
320  (defun compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
321    (let ((end (or end most-positive-fixnum))    (let ((end (or end most-positive-fixnum))
322          (backtrace '()))          (backtrace '()))
323      (do ((frame (nth-frame start) (dbg::frame-next frame))      (do ((frame (nth-frame start) (dbg::frame-next frame))
# Line 188  Return NIL if the symbol is unbound." Line 327  Return NIL if the symbol is unbound."
327          (incf i)          (incf i)
328          (push frame backtrace)))))          (push frame backtrace)))))
329    
330  (defmethod backtrace (start end)  (defun frame-actual-args (frame)
331    (flet ((format-frame (f i)    (let ((*break-on-signals* nil))
332             (print-with-frame-label      (mapcar (lambda (arg)
333              i (lambda (s)                (case arg
334                 (cond ((dbg::call-frame-p f)                  ((&rest &optional &key) arg)
335                        (format s "~A ~A"                  (t
336                                (dbg::call-frame-function-name f)                   (handler-case (dbg::dbg-eval arg frame)
337                                (dbg::call-frame-arglist f)))                     (error (e) (format nil "<~A>" arg))))))
338                       (t (princ f s)))))))              (dbg::call-frame-arglist frame))))
339      (loop for i from start  
340            for f in (compute-backtrace start end)  (defimplementation print-frame (frame stream)
341            collect (list i (format-frame f i)))))    (cond ((dbg::call-frame-p frame)
342             (format stream "~S ~S"
343  (defmethod debugger-info-for-emacs (start end)                   (dbg::call-frame-function-name frame)
344    (list (debugger-condition-for-emacs)                   (frame-actual-args frame)))
345          (format-restarts-for-emacs)          (t (princ frame stream))))
         (backtrace start end)))  
   
 (defun nth-restart (index)  
   (nth index *sldb-restarts*))  
346    
347  (defslimefun invoke-nth-restart (index)  (defun frame-vars (frame)
348    (invoke-restart-interactively (nth-restart index)))    (first (dbg::frame-locals-format-list frame #'list 75 0)))
349    
350  (defmethod frame-locals (n)  (defimplementation frame-locals (n)
351    (let ((frame (nth-frame n)))    (let ((frame (nth-frame n)))
352      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
353          (destructuring-bind (vars with)          (mapcar (lambda (var)
354              (dbg::frame-locals-format-list frame #'list 75 0)                    (destructuring-bind (name value symbol location) var
355            (declare (ignore with))                      (declare (ignore name location))
356            (loop for (name value symbol location) in vars                      (list :name symbol :id 0
357                  collect (list :name (to-string symbol) :id 0                            :value value)))
358                                :value-string (princ-to-string value)))))))                  (frame-vars frame)))))
   
 (defmethod frame-catch-tags (index)  
   (declare (ignore index))  
   nil)  
359    
360  (defmethod frame-source-location-for-emacs (frame)  (defimplementation frame-var-value (frame var)
361    (let ((frame (nth-frame frame)))    (let ((frame (nth-frame frame)))
362        (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
363          (declare (ignore _n _s _l))
364          value)))
365    
366    (defimplementation frame-source-location-for-emacs (frame)
367      (let ((frame (nth-frame frame))
368            (callee (if (plusp frame) (nth-frame (1- frame)))))
369      (if (dbg::call-frame-p frame)      (if (dbg::call-frame-p frame)
370          (let ((func (dbg::call-frame-function-name frame)))          (let ((dspec (dbg::call-frame-function-name frame))
371            (if func                (cname (and (dbg::call-frame-p callee)
372                (dspec-source-location func))))))                            (dbg::call-frame-function-name callee))))
373              (if dspec
374  (defun dspec-source-location (dspec)                (frame-location dspec cname))))))
375    (destructuring-bind (first) (dspec-source-locations dspec)  
376      first))  (defimplementation eval-in-frame (form frame-number)
377      (let ((frame (nth-frame frame-number)))
378  (defun dspec-source-locations (dspec)      (dbg::dbg-eval form frame)))
379    (let ((locations (dspec:find-dspec-locations dspec)))  
380      (cond ((not locations)  (defimplementation return-from-frame (frame-number form)
381             (list :error (format nil "Cannot find source for ~S" dspec)))    (let* ((frame (nth-frame frame-number))
382            (t           (return-frame (dbg::find-frame-for-return frame)))
383             (loop for (dspec location) in locations      (dbg::dbg-return-from-call-frame frame form return-frame
384                   collect (make-dspec-location dspec location))))))                                       dbg::*debugger-stack*)))
385    
386  (defmethod find-function-locations (fname)  (defimplementation restart-frame (frame-number)
387    (dspec-source-locations (from-string fname)))    (let ((frame (nth-frame frame-number)))
388        (dbg::restart-frame frame :same-args t)))
389  ;;; callers  
390    (defimplementation disassemble-frame (frame-number)
391  (defun stringify-function-name-list (list)    (let* ((frame (nth-frame frame-number)))
392    (let ((*print-pretty* nil)) (mapcar #'to-string list)))      (when (dbg::call-frame-p frame)
393          (let ((function (dbg::get-call-frame-function frame)))
394  (defslimefun list-callers (symbol-name)          (disassemble function)))))
395    (stringify-function-name-list (hcl:who-calls (from-string symbol-name))))  
396    ;;; Definition finding
397  ;;; Compilation  
398    (defun frame-location (dspec callee-name)
399  (defmethod compile-file-for-emacs (filename load-p)    (let ((infos (dspec:find-dspec-locations dspec)))
400    (let ((compiler::*error-database* '()))      (cond (infos
401               (destructuring-bind ((rdspec location) &rest _) infos
402                 (declare (ignore _))
403                 (let ((name (and callee-name (symbolp callee-name)
404                                  (string callee-name))))
405                   (make-dspec-location rdspec location
406                                        `(:call-site ,name)))))
407              (t
408               (list :error (format nil "Source location not available for: ~S"
409                                    dspec))))))
410    
411    (defimplementation find-definitions (name)
412      (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
413        (loop for (dspec location) in locations
414              collect (list dspec (make-dspec-location dspec location)))))
415    
416    
417    ;;; Compilation
418    
419    (defmacro with-swank-compilation-unit ((location &rest options) &body body)
420      (lw:rebinding (location)
421        `(let ((compiler::*error-database* '()))
422           (with-compilation-unit ,options
423             (multiple-value-prog1 (progn ,@body)
424               (signal-error-data-base compiler::*error-database*
425                                       ,location)
426               (signal-undefined-functions compiler::*unknown-functions*
427                                           ,location))))))
428    
429    (defimplementation swank-compile-file (input-file output-file
430                                           load-p external-format)
431      (with-swank-compilation-unit (input-file)
432        (compile-file input-file
433                      :output-file output-file
434                      :load load-p
435                      :external-format external-format)))
436    
437    (defvar *within-call-with-compilation-hooks* nil
438      "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
439    
440    (defvar *undefined-functions-hash* nil
441      "Hash table to map info about undefined functions to pathnames.")
442    
443    (lw:defadvice (compile-file compile-file-and-collect-notes :around)
444        (pathname &rest rest)
445      (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
446        (when *within-call-with-compilation-hooks*
447          (maphash (lambda (unfun dspecs)
448                     (dolist (dspec dspecs)
449                       (let ((unfun-info (list unfun dspec)))
450                         (unless (gethash unfun-info *undefined-functions-hash*)
451                           (setf (gethash unfun-info *undefined-functions-hash*)
452                                   pathname)))))
453                   compiler::*unknown-functions*))))
454    
455    (defimplementation call-with-compilation-hooks (function)
456      (let ((compiler::*error-database* '())
457            (*undefined-functions-hash* (make-hash-table :test 'equal))
458            (*within-call-with-compilation-hooks* t))
459      (with-compilation-unit ()      (with-compilation-unit ()
460        (compile-file filename :load load-p)        (prog1 (funcall function)
461        (signal-error-data-base compiler::*error-database*)          (signal-error-data-base compiler::*error-database*)
462        (signal-undefined-functions compiler::*unknown-functions* filename))))          (signal-undefined-functions compiler::*unknown-functions*)))))
463    
464  (defun map-error-database (database fn)  (defun map-error-database (database fn)
465    (loop for (filename . defs) in database do    (loop for (filename . defs) in database do
466          (loop for (dspec . conditions) in defs do          (loop for (dspec . conditions) in defs do
467                (dolist (c conditions)                (dolist (c conditions)
468                  (funcall fn filename dspec c)))))                  (funcall fn filename dspec (if (consp c) (car c) c))))))
469    
470  (defun lispworks-severity (condition)  (defun lispworks-severity (condition)
471    (cond ((not condition) :warning)    (cond ((not condition) :warning)
# Line 286  Return NIL if the symbol is unbound." Line 482  Return NIL if the symbol is unbound."
482                    :location location                    :location location
483                    :original-condition condition)))                    :original-condition condition)))
484    
485    (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
486    
487  (defun compile-from-temp-file (string filename)  (defun compile-from-temp-file (string filename)
488    (unwind-protect    (unwind-protect
489         (progn         (progn
490           (with-open-file (s filename :direction :output :if-exists :supersede)           (with-open-file (s filename :direction :output
491                                         :if-exists :supersede
492                                         :external-format *temp-file-format*)
493    
494             (write-string string s)             (write-string string s)
495             (finish-output s))             (finish-output s))
496           (let ((binary-filename (compile-file filename :load t)))           (multiple-value-bind (binary-filename warnings? failure?)
497                 (compile-file filename :load t
498                               :external-format *temp-file-format*)
499               (declare (ignore warnings?))
500             (when binary-filename             (when binary-filename
501               (delete-file binary-filename))))               (delete-file binary-filename))
502               (not failure?)))
503      (delete-file filename)))      (delete-file filename)))
504    
505  (defun make-dspec-location (dspec location &optional tmpfile buffer position)  (defun dspec-function-name-position (dspec fallback)
506    (flet ((from-buffer-p ()    (etypecase dspec
507             (and (pathnamep location) tmpfile      (cons (let ((name (dspec:dspec-primary-name dspec)))
508                  (pathname-match-p location tmpfile)))              (typecase name
509           (filename (pathname)                ((or symbol string)
510             (multiple-value-bind (truename condition)                 (list :function-name (string name)))
511                 (ignore-errors (truename pathname))                (t fallback))))
512               (cond (condition      (null fallback)
513                      (return-from make-dspec-location      (symbol (list :function-name (string dspec)))))
514                        (list :error (format nil "~A" condition))))  
515                     (t (namestring truename)))))  (defmacro with-fairly-standard-io-syntax (&body body)
516           (function-name (dspec)    "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
517             (etypecase dspec    (let ((package (gensym))
518               (symbol (symbol-name dspec))          (readtable (gensym)))
519               (cons (symbol-name (dspec:dspec-primary-name dspec))))))      `(let ((,package *package*)
520      (cond ((from-buffer-p)             (,readtable *readtable*))
521             (make-location `(:buffer ,buffer) `(:position ,position)))        (with-standard-io-syntax
522            (t          (let ((*package* ,package)
523             (etypecase location                (*readtable* ,readtable))
524               (pathname            ,@body)))))
525                (make-location `(:file ,(filename location))  
526                               `(:function-name ,(function-name dspec))))  (defun skip-comments (stream)
527               ((member :listener)    (let ((pos0 (file-position stream)))
528                `(:error ,(format nil "Function defined in listener: ~S" dspec)))      (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
529               ((member :unknown)                    '(()))
530                `(:error ,(format nil "Function location unkown: ~S" dspec))))             (file-position stream (1- (file-position stream))))
531             ))))            (t (file-position stream pos0)))))
532    
533    #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
534    (defun dspec-stream-position (stream dspec)
535      (with-fairly-standard-io-syntax
536        (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
537                     (form (read stream nil '#1=#:eof)))
538                (when (eq form '#1#)
539                  (return nil))
540                (labels ((check-dspec (form)
541                           (when (consp form)
542                             (let ((operator (car form)))
543                               (case operator
544                                 ((progn)
545                                  (mapcar #'check-dspec
546                                          (cdr form)))
547                                 ((eval-when locally macrolet symbol-macrolet)
548                                  (mapcar #'check-dspec
549                                          (cddr form)))
550                                 ((in-package)
551                                  (let ((package (find-package (second form))))
552                                    (when package
553                                      (setq *package* package))))
554                                 (otherwise
555                                  (let ((form-dspec (dspec:parse-form-dspec form)))
556                                    (when (dspec:dspec-equal dspec form-dspec)
557                                      (return pos)))))))))
558                  (check-dspec form))))))
559    
560    (defun dspec-file-position (file dspec)
561      (let* ((*compile-file-pathname* (pathname file))
562             (*compile-file-truename* (truename *compile-file-pathname*))
563             (*load-pathname* *compile-file-pathname*)
564             (*load-truename* *compile-file-truename*))
565        (with-open-file (stream file)
566          (let ((pos
567                 #-(or lispworks4.1 lispworks4.2)
568                 (dspec-stream-position stream dspec)))
569            (if pos
570                (list :position (1+ pos))
571                (dspec-function-name-position dspec `(:position 1)))))))
572    
573    (defun emacs-buffer-location-p (location)
574      (and (consp location)
575           (eq (car location) :emacs-buffer)))
576    
577    (defun make-dspec-location (dspec location &optional hints)
578      (etypecase location
579        ((or pathname string)
580         (multiple-value-bind (file err)
581             (ignore-errors (namestring (truename location)))
582           (if err
583               (list :error (princ-to-string err))
584               (make-location `(:file ,file)
585                              (dspec-file-position file dspec)
586                              hints))))
587        (symbol
588         `(:error ,(format nil "Cannot resolve location: ~S" location)))
589        ((satisfies emacs-buffer-location-p)
590         (destructuring-bind (_ buffer offset string) location
591           (declare (ignore _ string))
592           (make-location `(:buffer ,buffer)
593                          (dspec-function-name-position dspec `(:offset ,offset 0))
594                          hints)))))
595    
596    (defun make-dspec-progenitor-location (dspec location)
597      (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
598        (make-dspec-location
599         (if canon-dspec
600             (if (dspec:local-dspec-p canon-dspec)
601                 (dspec:dspec-progenitor canon-dspec)
602               canon-dspec)
603           nil)
604         location)))
605    
606  (defun signal-error-data-base (database &optional tmpfile buffer position)  (defun signal-error-data-base (database &optional location)
607    (map-error-database    (map-error-database
608     database     database
609     (lambda (filename dspec condition)     (lambda (filename dspec condition)
610       (signal-compiler-condition       (signal-compiler-condition
611        (format nil "~A" condition)        (format nil "~A" condition)
612        (make-dspec-location dspec filename tmpfile buffer position)        (make-dspec-progenitor-location dspec (or location filename))
613        condition))))        condition))))
614    
615  (defun signal-undefined-functions (htab filename  (defun unmangle-unfun (symbol)
616                                     &optional tmpfile buffer position)    "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
617    function names like \(SETF GET)."
618      (cond ((sys::setf-symbol-p symbol)
619             (sys::setf-pair-from-underlying-name symbol))
620            (t symbol)))
621    
622    (defun signal-undefined-functions (htab &optional filename)
623    (maphash (lambda (unfun dspecs)    (maphash (lambda (unfun dspecs)
624               (dolist (dspec dspecs)               (dolist (dspec dspecs)
625                 (signal-compiler-condition                 (signal-compiler-condition
626                  (format nil "Undefined function ~A" unfun)                  (format nil "Undefined function ~A" (unmangle-unfun unfun))
627                  (make-dspec-location dspec filename tmpfile buffer position)                  (make-dspec-progenitor-location dspec
628                                                    (or filename
629                                                        (gethash (list unfun dspec)
630                                                                 *undefined-functions-hash*)))
631                  nil)))                  nil)))
632             htab))             htab))
633    
634  (defmethod compile-string-for-emacs (string &key buffer position)  (defimplementation swank-compile-string (string &key buffer position filename
635                                             policy)
636      (declare (ignore filename policy))
637    (assert buffer)    (assert buffer)
638    (assert position)    (assert position)
639    (let ((*package* *buffer-package*)    (let* ((location (list :emacs-buffer buffer position string))
640          (compiler::*error-database* '())           (tmpname (hcl:make-temp-file nil "lisp")))
641          (tmpname (hcl:make-temp-file nil "lisp")))      (with-swank-compilation-unit (location)
642      (with-compilation-unit ()        (compile-from-temp-file
643        (compile-from-temp-file string tmpname)         (with-output-to-string (s)
644        (format t "~A~%" compiler:*messages*)           (let ((*print-radix* t))
645        (signal-error-data-base             (print `(eval-when (:compile-toplevel)
646         compiler::*error-database* tmpname buffer position)                       (setq dspec::*location* (list ,@location)))
647        (signal-undefined-functions compiler::*unknown-functions*                    s))
648                                    tmpname tmpname buffer position))))           (write-string string s))
649           tmpname))))
650    
651  ;;; xref  ;;; xref
652    
653  (defun lookup-xrefs (finder name)  (defmacro defxref (name function)
654    (xref-results-for-emacs (funcall finder (from-string name))))    `(defimplementation ,name (name)
655        (xref-results (,function name))))
656    
657    (defxref who-calls      hcl:who-calls)
658    (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
659    (defxref calls-who      hcl:calls-who)
660    (defxref list-callers   list-callers-internal)
661    ;; (defxref list-callees   list-callees-internal)
662    
663    (defun list-callers-internal (name)
664      (let ((callers (make-array 100
665                                 :fill-pointer 0
666                                 :adjustable t)))
667        (hcl:sweep-all-objects
668         #'(lambda (object)
669             (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
670                        #-Harlequin-PC-Lisp (sys::callablep object)
671                        (system::find-constant$funcallable name object))
672               (vector-push-extend object callers))))
673        ;; Delay dspec:object-dspec until after sweep-all-objects
674        ;; to reduce allocation problems.
675        (loop for object across callers
676              collect (if (symbolp object)
677                          (list 'function object)
678                          (or (dspec:object-dspec object) object)))))
679    
680    ;; only for lispworks 4.2 and above
681    #-lispworks4.1
682    (progn
683      (defxref who-references hcl:who-references)
684      (defxref who-binds      hcl:who-binds)
685      (defxref who-sets       hcl:who-sets))
686    
687    (defimplementation who-specializes (classname)
688      (let ((methods (clos:class-direct-methods (find-class classname))))
689        (xref-results (mapcar #'dspec:object-dspec methods))))
690    
691    (defun xref-results (dspecs)
692      (flet ((frob-locs (dspec locs)
693               (cond (locs
694                      (loop for (name loc) in locs
695                            collect (list name (make-dspec-location name loc))))
696                     (t `((,dspec (:error "Source location not available")))))))
697        (loop for dspec in dspecs
698              append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
699    
700    ;;; Inspector
701    
702    (defmethod emacs-inspect ((o t))
703      (lispworks-inspect o))
704    
705    (defmethod emacs-inspect ((o function))
706      (lispworks-inspect o))
707    
708    ;; FIXME: slot-boundp-using-class in LW works with names so we can't
709    ;; use our method in swank.lisp.
710    (defmethod emacs-inspect ((o standard-object))
711      (lispworks-inspect o))
712    
713    (defun lispworks-inspect (o)
714      (multiple-value-bind (names values _getter _setter type)
715          (lw:get-inspector-values o nil)
716        (declare (ignore _getter _setter))
717                (append
718                 (label-value-line "Type" type)
719                 (loop for name in names
720                       for value in values
721                       append (label-value-line name value)))))
722    
723    ;;; Miscellaneous
724    
725    (defimplementation quit-lisp ()
726      (lispworks:quit))
727    
728    ;;; Tracing
729    
730    (defun parse-fspec (fspec)
731      "Return a dspec for FSPEC."
732      (ecase (car fspec)
733        ((:defmethod) `(method ,(cdr fspec)))))
734    
735    (defun tracedp (dspec)
736      (member dspec (eval '(trace)) :test #'equal))
737    
738    (defun toggle-trace-aux (dspec)
739      (cond ((tracedp dspec)
740             (eval `(untrace ,dspec))
741             (format nil "~S is now untraced." dspec))
742            (t
743             (eval `(trace (,dspec)))
744             (format nil "~S is now traced." dspec))))
745    
746    (defimplementation toggle-trace (fspec)
747      (toggle-trace-aux (parse-fspec fspec)))
748    
749    ;;; Multithreading
750    
751    (defimplementation initialize-multiprocessing (continuation)
752      (cond ((not mp::*multiprocessing*)
753             (push (list "Initialize SLIME" '() continuation)
754                   mp:*initial-processes*)
755             (mp:initialize-multiprocessing))
756            (t (funcall continuation))))
757    
758    (defimplementation spawn (fn &key name)
759      (mp:process-run-function name () fn))
760    
761  (defslimefun who-calls (function-name)  (defvar *id-lock* (mp:make-lock))
762    (lookup-xrefs #'hcl:who-calls function-name))  (defvar *thread-id-counter* 0)
763    
764  (defslimefun who-references (variable)  (defimplementation thread-id (thread)
765    (lookup-xrefs #'hcl:who-references variable))    (mp:with-lock (*id-lock*)
766        (or (getf (mp:process-plist thread) 'id)
767            (setf (getf (mp:process-plist thread) 'id)
768                  (incf *thread-id-counter*)))))
769    
770    (defimplementation find-thread (id)
771      (find id (mp:list-all-processes)
772            :key (lambda (p) (getf (mp:process-plist p) 'id))))
773    
774    (defimplementation thread-name (thread)
775      (mp:process-name thread))
776    
777    (defimplementation thread-status (thread)
778      (format nil "~A ~D"
779              (mp:process-whostate thread)
780              (mp:process-priority thread)))
781    
782    (defimplementation make-lock (&key name)
783      (mp:make-lock :name name))
784    
785    (defimplementation call-with-lock-held (lock function)
786      (mp:with-lock (lock) (funcall function)))
787    
788    (defimplementation current-thread ()
789      mp:*current-process*)
790    
791    (defimplementation all-threads ()
792      (mp:list-all-processes))
793    
794    (defimplementation interrupt-thread (thread fn)
795      (mp:process-interrupt thread fn))
796    
797    (defimplementation kill-thread (thread)
798      (mp:process-kill thread))
799    
800    (defimplementation thread-alive-p (thread)
801      (mp:process-alive-p thread))
802    
803    (defstruct (mailbox (:conc-name mailbox.))
804      (mutex (mp:make-lock :name "thread mailbox"))
805      (queue '() :type list))
806    
807    (defvar *mailbox-lock* (mp:make-lock))
808    
809    (defun mailbox (thread)
810      (mp:with-lock (*mailbox-lock*)
811        (or (getf (mp:process-plist thread) 'mailbox)
812            (setf (getf (mp:process-plist thread) 'mailbox)
813                  (make-mailbox)))))
814    
815    (defimplementation receive-if (test &optional timeout)
816      (let* ((mbox (mailbox mp:*current-process*))
817             (lock (mailbox.mutex mbox)))
818        (assert (or (not timeout) (eq timeout t)))
819        (loop
820         (check-slime-interrupts)
821         (mp:with-lock (lock "receive-if/try")
822           (let* ((q (mailbox.queue mbox))
823                  (tail (member-if test q)))
824             (when tail
825               (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
826               (return (car tail)))))
827         (when (eq timeout t) (return (values nil t)))
828         (mp:process-wait-with-timeout
829          "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
830    
831    (defimplementation send (thread message)
832      (let ((mbox (mailbox thread)))
833        (mp:with-lock ((mailbox.mutex mbox))
834          (setf (mailbox.queue mbox)
835                (nconc (mailbox.queue mbox) (list message))))))
836    
837    (defimplementation set-default-initial-binding (var form)
838      (setq mp:*process-initial-bindings*
839            (acons var `(eval (quote ,form))
840                   mp:*process-initial-bindings* )))
841    
842    ;;; Some intergration with the lispworks environment
843    
844    (defun swank-sym (name) (find-symbol (string name) :swank))
845    
846    
847    ;;;; Weak hashtables
848    
849  (defslimefun who-binds (variable)  (defimplementation make-weak-key-hash-table (&rest args)
850    (lookup-xrefs #'hcl:who-binds variable))    (apply #'make-hash-table :weak-kind :key args))
   
 (defslimefun who-sets (variable)  
   (lookup-xrefs #'hcl:who-sets variable))  
   
 (defun xref-results-for-emacs (dspecs)  
   (let ((xrefs '()))  
     (dolist (dspec dspecs)  
       (loop for (dspec location) in (dspec:find-dspec-locations dspec)  
             do (push (cons (to-string dspec)  
                            (make-dspec-location dspec location))  
                      xrefs)))  
     (group-xrefs xrefs)))  
   
 (defslimefun list-callers (symbol-name)  
   (lookup-xrefs #'hcl:who-calls symbol-name))  
   
 (defslimefun list-callees (symbol-name)  
   (lookup-xrefs #'hcl:calls-who symbol-name))  
   
 ;; (dspec:at-location  
 ;;  ('(:inside (:buffer "foo" 34)))  
 ;;  (defun foofun () (foofun)))  
851    
 ;; (dspec:find-dspec-locations 'xref-results-for-emacs)  
 ;; (who-binds '*package*)  
852    (defimplementation make-weak-value-hash-table (&rest args)
853      (apply #'make-hash-table :weak-kind :value args))

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.128

  ViewVC Help
Powered by ViewVC 1.1.5