/[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.31 by heller, Tue Mar 9 19:35:36 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 11  Line 11 
11  (in-package :swank-backend)  (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))
16    
17  (import  (import-swank-mop-symbols :clos '(:slot-definition-documentation
18   '(stream:fundamental-character-output-stream                                    :eql-specializer
19     stream:stream-write-char                                    :eql-specializer-object
20     stream:stream-force-output                                    :compute-applicable-methods-using-classes))
21     stream:fundamental-character-input-stream  
22     stream:stream-read-char  (defun swank-mop:slot-definition-documentation (slot)
23     stream:stream-listen    (documentation slot t))
24     stream:stream-unread-char  
25     stream:stream-clear-input  (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
26     stream:stream-line-column    (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    
# Line 37  Line 54 
54    
55  (defimplementation create-socket (host port)  (defimplementation create-socket (host port)
56    (multiple-value-bind (socket where errno)    (multiple-value-bind (socket where errno)
57          #-(or lispworks4.1 (and macosx lispworks4.3))
58        (comm::create-tcp-socket-for-service port :address host)        (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            (t (error 'network-error
63                :format-control "~A failed: ~A (~D)"                :format-control "~A failed: ~A (~D)"
# Line 51  Line 71 
71  (defimplementation close-socket (socket)  (defimplementation close-socket (socket)
72    (comm::close-socket (socket-fd socket)))    (comm::close-socket (socket-fd socket)))
73    
74  (defimplementation 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  (defimplementation emacs-connected ()                            :socket fd
83    ;; Set SIGINT handler on Swank request handler thread.                            :direction :io
84    #-win32                            :read-timeout timeout
85    (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*)))                            :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  ;;; Unix signals
128    
# Line 73  Line 135 
135      (declare (ignore args))      (declare (ignore args))
136      (mp:process-interrupt process #'sigint-handler)))      (mp:process-interrupt process #'sigint-handler)))
137    
138  (defmethod call-without-interrupts (fn)  (defun set-sigint-handler ()
139    (lispworks:without-interrupts (funcall fn)))    ;; Set SIGINT handler on Swank request handler thread.
140      #-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 ()  (defimplementation getpid ()
156    #+win32 (win32:get-current-process-id)    #+win32 (win32:get-current-process-id)
157    #-win32 (system::getpid))    #-win32 (system::getpid))
# Line 83  Line 159 
159  (defimplementation lisp-implementation-type-name ()  (defimplementation lisp-implementation-type-name ()
160    "lispworks")    "lispworks")
161    
162  (defimplementation arglist (symbol)  (defimplementation set-default-directory (directory)
163    (let ((arglist (lw:function-lambda-list symbol)))    (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      (etypecase arglist
170        ((member :dont-know)        ((member :dont-know)
171         (error "<arglist-unavailable>"))         :not-available)
172        (list arglist))))        (list
173           arglist))))
174    
175    (defimplementation function-name (function)
176      (nth-value 2 (function-lambda-expression function)))
177    
178  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
179    (walker:walk-form form))    (walker:walk-form form))
180    
181    (defun generic-function-p (object)
182      (typep object 'generic-function))
183    
184  (defimplementation describe-symbol-for-emacs (symbol)  (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."
# Line 101  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 112  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        result)))        result)))
# Line 123  Return NIL if the symbol is unbound." Line 220  Return NIL if the symbol is unbound."
220    (ecase type    (ecase type
221      (:variable (describe-symbol symbol))      (:variable (describe-symbol symbol))
222      (:class (describe (find-class symbol)))      (:class (describe (find-class symbol)))
223      (:function (describe-function symbol))))      ((:function :generic-function) (describe-function symbol))
224        (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
225    
226  (defun describe-function (symbol)  (defun describe-function (symbol)
227    (cond ((fboundp symbol)    (cond ((fboundp symbol)
228           (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"           (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
229                   (string-downcase symbol)                   symbol
230                   (mapcar #'string-upcase                   (lispworks:function-lambda-list symbol)
                          (lispworks:function-lambda-list symbol))  
231                   (documentation symbol 'function))                   (documentation symbol 'function))
232           (describe (symbol-function symbol)))           (describe (fdefinition symbol)))
233          (t (format t "~S is not fbound" symbol))))          (t (format t "~S is not fbound" symbol))))
234    
235  (defun describe-symbol (sym)  (defun describe-symbol (sym)
# Line 147  Return NIL if the symbol is unbound." Line 244  Return NIL if the symbol is unbound."
244    
245  ;;; Debugging  ;;; Debugging
246    
247  (defvar *sldb-top-frame*)  (defclass slime-env (env:environment)
248      ((debugger-hook :initarg :debugger-hoook)))
249    
250  (defimplementation call-with-debugging-environment (fn)  (defun slime-env (hook io-bindings)
251    (dbg::with-debugger-stack ()    (make-instance 'slime-env :name "SLIME Environment"
252      (let ((*sldb-top-frame* (dbg::debugger-stack-current-frame                   :io-bindings io-bindings
253                               dbg::*debugger-stack*)))                   :debugger-hoook hook))
254        (funcall fn))))  
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    (defvar *sldb-top-frame*)
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 *sldb-top-frame* (dbg::frame-next frame))    (nth-next-frame *sldb-top-frame* index))
302         (i index (if (interesting-frame-p frame) (1- i) i)))  
303        ((and (interesting-frame-p frame) (zerop i)) frame)  (defun find-top-frame ()
304      (assert frame)))    "Return the most suitable top-frame for the debugger."
305      (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  (defimplementation compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
321    (let ((end (or end most-positive-fixnum))    (let ((end (or end most-positive-fixnum))
# Line 176  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    (defun frame-actual-args (frame)
331      (let ((*break-on-signals* nil))
332        (mapcar (lambda (arg)
333                  (case arg
334                    ((&rest &optional &key) arg)
335                    (t
336                     (handler-case (dbg::dbg-eval arg frame)
337                       (error (e) (format nil "<~A>" arg))))))
338                (dbg::call-frame-arglist frame))))
339    
340  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
341    (cond ((dbg::call-frame-p frame)    (cond ((dbg::call-frame-p frame)
342           (format stream "~A ~A"           (format stream "~S ~S"
343                   (dbg::call-frame-function-name frame)                   (dbg::call-frame-function-name frame)
344                   (dbg::call-frame-arglist frame)))                   (frame-actual-args frame)))
345          (t (princ frame stream))))          (t (princ frame stream))))
346    
347    (defun frame-vars (frame)
348      (first (dbg::frame-locals-format-list frame #'list 75 0)))
349    
350  (defimplementation 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            (mapcar (lambda (var)                      (list :name symbol :id 0
357                      (destructuring-bind (name value symbol location) var                            :value value)))
358                        (declare (ignore name location))                  (frame-vars frame)))))
                       (list :name symbol :id 0  
                             :value value)))  
                   vars)))))  
   
 (defimplementation frame-catch-tags (index)  
   (declare (ignore index))  
   nil)  
359    
360  (defimplementation 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                (cadr (name-source-location func)))))))                            (dbg::call-frame-function-name callee))))
373              (if dspec
374                  (frame-location dspec cname))))))
375    
376  (defimplementation eval-in-frame (form frame-number)  (defimplementation eval-in-frame (form frame-number)
377    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
# Line 221  Return NIL if the symbol is unbound." Line 387  Return NIL if the symbol is unbound."
387    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
388      (dbg::restart-frame frame :same-args t)))      (dbg::restart-frame frame :same-args t)))
389    
390  ;;; Definition finding  (defimplementation disassemble-frame (frame-number)
391      (let* ((frame (nth-frame frame-number)))
392        (when (dbg::call-frame-p frame)
393          (let ((function (dbg::get-call-frame-function frame)))
394            (disassemble function)))))
395    
396  (defun name-source-location (name)  ;;; Definition finding
   (first (name-source-locations name)))  
397    
398  (defun name-source-locations (name)  (defun frame-location (dspec callee-name)
399    (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))    (let ((infos (dspec:find-dspec-locations dspec)))
400      (cond ((not locations)      (cond (infos
401             (list :error (format nil "Cannot find source for ~S" name)))             (destructuring-bind ((rdspec location) &rest _) infos
402            (t               (declare (ignore _))
403             (loop for (dspec location) in locations               (let ((name (and callee-name (symbolp callee-name)
404                   collect (list dspec (make-dspec-location dspec location)))))))                                (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)  (defimplementation find-definitions (name)
412    (name-source-locations name))    (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  ;;; Compilation
418    
419  (defimplementation swank-compile-file (filename load-p)  (defmacro with-swank-compilation-unit ((location &rest options) &body body)
420    (let ((compiler::*error-database* '()))    (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* filename)          (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 267  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  ;; XXX handle all cases in dspec:*dspec-classes*  (defun dspec-function-name-position (dspec fallback)
 (defun dspec-buffer-position (dspec)  
506    (etypecase dspec    (etypecase dspec
507      (cons (ecase (car dspec)      (cons (let ((name (dspec:dspec-primary-name dspec)))
508              ((defun defmacro defgeneric defvar defstruct              (typecase name
509                      method structure package)                ((or symbol string)
510               `(:function-name ,(symbol-name (cadr dspec))))                 (list :function-name (string name)))
511              ;; XXX this isn't quite right                (t fallback))))
512              (lw:top-level-form `(:source-path ,(cdr dspec) nil))))      (null fallback)
513      (symbol `(:function-name ,(symbol-name dspec)))))      (symbol (list :function-name (string dspec)))))
514    
515    (defmacro with-fairly-standard-io-syntax (&body body)
516      "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
517      (let ((package (gensym))
518            (readtable (gensym)))
519        `(let ((,package *package*)
520               (,readtable *readtable*))
521          (with-standard-io-syntax
522            (let ((*package* ,package)
523                  (*readtable* ,readtable))
524              ,@body)))))
525    
526    (defun skip-comments (stream)
527      (let ((pos0 (file-position stream)))
528        (cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
529                      '(()))
530               (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)  (defun emacs-buffer-location-p (location)
574    (and (consp location)    (and (consp location)
575         (eq (car location) :emacs-buffer)))         (eq (car location) :emacs-buffer)))
576    
577  (defun make-dspec-location (dspec location)  (defun make-dspec-location (dspec location &optional hints)
578    (flet ((filename (pathname)    (etypecase location
579             (multiple-value-bind (truename condition)      ((or pathname string)
580                 (ignore-errors (truename pathname))       (multiple-value-bind (file err)
581               (cond (condition           (ignore-errors (namestring (truename location)))
582                      (return-from make-dspec-location         (if err
583                        (list :error (format nil "~A" condition))))             (list :error (princ-to-string err))
584                     (t (namestring truename)))))             (make-location `(:file ,file)
585           (function-name (dspec)                            (dspec-file-position file dspec)
586             (etypecase dspec                            hints))))
587               (symbol (symbol-name dspec))      (symbol
588               (cons (string (dspec:dspec-primary-name dspec))))))       `(:error ,(format nil "Cannot resolve location: ~S" location)))
589      (etypecase location      ((satisfies emacs-buffer-location-p)
590        ((or pathname string)       (destructuring-bind (_ buffer offset string) location
591         (make-location `(:file ,(filename location))         (declare (ignore _ string))
592                        (dspec-buffer-position dspec)))         (make-location `(:buffer ,buffer)
593        ((member :listener)                        (dspec-function-name-position dspec `(:offset ,offset 0))
594         `(:error ,(format nil "Function defined in listener: ~S" dspec)))                        hints)))))
595        ((member :unknown)  
596         `(:error ,(format nil "Function location unkown: ~S" dspec)))  (defun make-dspec-progenitor-location (dspec location)
597        ((satisfies emacs-buffer-location-p)    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
598         (destructuring-bind (_ buffer offset string) location      (make-dspec-location
599           (declare (ignore _ offset string))       (if canon-dspec
600           (make-location `(:buffer ,buffer)           (if (dspec:local-dspec-p canon-dspec)
601                          (dspec-buffer-position dspec)))))))               (dspec:dspec-progenitor canon-dspec)
602               canon-dspec)
603           nil)
604         location)))
605    
606  (defun signal-error-data-base (database location)  (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)
      (declare (ignore filename))  
610       (signal-compiler-condition       (signal-compiler-condition
611        (format nil "~A" condition)        (format nil "~A" condition)
612        (make-dspec-location dspec location)        (make-dspec-progenitor-location dspec (or location filename))
613        condition))))        condition))))
614    
615  (defun signal-undefined-functions (htab filename)  (defun unmangle-unfun (symbol)
616      "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)                  (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  (defimplementation swank-compile-string (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* ((location (list :emacs-buffer buffer position string))    (let* ((location (list :emacs-buffer buffer position string))
          (compiler::*error-database* '())  
640           (tmpname (hcl:make-temp-file nil "lisp")))           (tmpname (hcl:make-temp-file nil "lisp")))
641      (with-compilation-unit ()      (with-swank-compilation-unit (location)
642        (compile-from-temp-file        (compile-from-temp-file
643         (with-standard-io-syntax         (with-output-to-string (s)
644           (format nil "~S~%~A" `(eval-when (:compile-toplevel)           (let ((*print-radix* t))
645                                  (setq dspec::*location* (list ,@location)))             (print `(eval-when (:compile-toplevel)
646                   string))                       (setq dspec::*location* (list ,@location)))
647         tmpname)                    s))
648        (signal-error-data-base compiler::*error-database* location)           (write-string string s))
649        (signal-undefined-functions compiler::*unknown-functions* location))))         tmpname))))
650    
651  ;;; xref  ;;; xref
652    
 <<<<<<< swank-lispworks.lisp  
653  (defmacro defxref (name function)  (defmacro defxref (name function)
654    `(defimplementation ,name (name)    `(defimplementation ,name (name)
655      (xref-results (,function name))))      (xref-results (,function name))))
656    
657  (defxref who-calls      hcl:who-calls)  (defxref who-calls      hcl:who-calls)
658  (defxref who-references hcl:who-references)  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
659  (defxref who-binds      hcl:who-binds)  (defxref calls-who      hcl:calls-who)
660  (defxref who-sets       hcl:who-sets)  (defxref list-callers   list-callers-internal)
661  (defxref list-callees   hcl:calls-who)  ;; (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)  (defun xref-results (dspecs)
692    (loop for dspec in dspecs    (flet ((frob-locs (dspec locs)
693          nconc (loop for (dspec location) in             (cond (locs
694                      (dspec:dspec-definition-locations dspec)                    (loop for (name loc) in locs
695                      collect (list dspec                          collect (list name (make-dspec-location name loc))))
696                                    (make-dspec-location dspec location)))))                   (t `((,dspec (:error "Source location not available")))))))
697  =======      (loop for dspec in dspecs
698  (defun xrefs (dspecs)            append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
   (loop for dspec in dspecs  
         nconc (loop for (dspec location) in  
                     (dspec:dspec-definition-locations dspec)  
                     collect (list dspec  
                                   (make-dspec-location dspec location)))))  
   
 (defimplementation who-calls (name)  
   (xrefs (hcl:who-calls name)))  
   
 (defimplementation who-references (name)  
   (xrefs (hcl:who-references name)))  
   
 (defimplementation who-binds (name)  
   (xrefs (hcl:who-binds name)))  
   
 (defimplementation who-sets (name)  
   (xrefs (hcl:who-sets name)))  
   
 (defimplementation list-callers (name)  
   (xrefs (hcl:who-calls name)))  
   
 (defimplementation list-callees (name)  
   (xrefs (hcl:calls-who name)))  
 >>>>>>> 1.30  
699    
700  ;;; Inspector  ;;; Inspector
701    
702  (defmethod inspected-parts (o)  (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)    (multiple-value-bind (names values _getter _setter type)
715        (lw:get-inspector-values o nil)        (lw:get-inspector-values o nil)
716      (declare (ignore _getter _setter))      (declare (ignore _getter _setter))
717      (values (format nil "~A~%   is a ~A" o type)              (append
718              (mapcar (lambda (name value)               (label-value-line "Type" type)
719                        (cons (princ-to-string name) value))               (loop for name in names
720                      names values))))                     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  ;;; Multithreading
750    
751  (defimplementation startup-multiprocessing ()  (defimplementation initialize-multiprocessing (continuation)
752    (mp:initialize-multiprocessing))    (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)  (defimplementation spawn (fn &key name)
759    (mp:process-run-function name () fn))    (mp:process-run-function name () fn))
760    
761    (defvar *id-lock* (mp:make-lock))
762    (defvar *thread-id-counter* 0)
763    
764    (defimplementation thread-id (thread)
765      (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)  (defimplementation thread-name (thread)
775    (mp:process-name thread))    (mp:process-name thread))
776    
# Line 448  Return NIL if the symbol is unbound." Line 800  Return NIL if the symbol is unbound."
800  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
801    (mp:process-alive-p thread))    (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))  (defvar *mailbox-lock* (mp:make-lock))
808    
809  (defun mailbox (thread)  (defun mailbox (thread)
810    (mp:with-lock (*mailbox-lock*)    (mp:with-lock (*mailbox-lock*)
811      (or (getf (mp:process-plist thread) 'mailbox)      (or (getf (mp:process-plist thread) 'mailbox)
812          (setf (getf (mp:process-plist thread) 'mailbox)          (setf (getf (mp:process-plist thread) 'mailbox)
813                (mp:make-mailbox)))))                (make-mailbox)))))
814    
815  (defimplementation receive ()  (defimplementation receive-if (test &optional timeout)
816    (mp:mailbox-read (mailbox mp:*current-process*)))    (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  (defimplementation send (thread object)  (defimplementation make-weak-key-hash-table (&rest args)
850    (mp:mailbox-send (mailbox thread) object))    (apply #'make-hash-table :weak-kind :key args))
851    
852    (defimplementation make-weak-value-hash-table (&rest args)
853      (apply #'make-hash-table :weak-kind :value args))

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

  ViewVC Help
Powered by ViewVC 1.1.5