/[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.28 by mbaringer, Fri Mar 5 14:26:14 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 8  Line 8 
8  ;;; are disclaimed.  ;;; are disclaimed.
9  ;;;  ;;;
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))
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    
47  (setq *swank-in-background* :spawn)  (defimplementation preferred-communication-style ()
48      :spawn)
49    
50  (defun socket-fd (socket)  (defun socket-fd (socket)
51    (etypecase socket    (etypecase socket
# Line 36  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 50  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    (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*)))                            :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  ;;; Unix signals
128    
# Line 71  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  (defmethod getpid ()    (sys::set-signal-handler +sigint+
142    (system::getpid))                             (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 ()  (defimplementation lisp-implementation-type-name ()
160    "lispworks")    "lispworks")
161    
162  (defimplementation arglist-string (fname)  (defimplementation set-default-directory (directory)
163    (format-arglist fname    (namestring (hcl:change-directory directory)))
164                    (lambda (symbol)  
165                      (let ((arglist (lw:function-lambda-list symbol)))  ;;;; Documentation
166                        (etypecase arglist  
167                          ((member :dont-know)  (defimplementation arglist (symbol-or-function)
168                           (error "<arglist-unavailable>"))    (let ((arglist (lw:function-lambda-list symbol-or-function)))
169                          (cons arglist))))))      (etypecase arglist
170          ((member :dont-know)
171           :not-available)
172          (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 100  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 111  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  (defimplementation describe-definition (symbol-name type)  (defimplementation describe-definition (symbol type)
220    (case type    (ecase type
221      ;; FIXME: This should cover all types returned by      (:variable (describe-symbol symbol))
222      ;; DESCRIBE-SYMBOL-FOR-EMACS.      (:class (describe (find-class symbol)))
223      (:function (describe-function symbol-name))))      ((:function :generic-function) (describe-function symbol))
224        (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
225  (defun describe-function (symbol-name)  
226    (with-output-to-string (*standard-output*)  (defun describe-function (symbol)
227      (let ((sym (from-string symbol-name)))    (cond ((fboundp symbol)
228        (cond ((fboundp sym)           (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
229               (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"                   symbol
230                       (string-downcase sym)                   (lispworks:function-lambda-list symbol)
231                       (mapcar #'string-upcase                   (documentation symbol 'function))
232                               (lispworks:function-lambda-list sym))           (describe (fdefinition symbol)))
233                       (documentation sym 'function))          (t (format t "~S is not fbound" symbol))))
              (describe (symbol-function sym)))  
             (t (format t "~S is not fbound" sym))))))  
234    
235  #+(or)  (defun describe-symbol (sym)
 (defimplementation 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 146  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  (defvar *sldb-top-frame*)    ((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  (defimplementation call-with-debugging-environment (fn)  (defvar *sldb-top-frame*)
   (dbg::with-debugger-stack ()  
     (let ((*sldb-restarts* (compute-restarts *swank-debugger-condition*))  
           (*sldb-top-frame* (dbg::debugger-stack-current-frame  
                              dbg::*debugger-stack*)))  
       (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 *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  (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 194  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  (defimplementation 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  (defimplementation 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  (defimplementation frame-locals (n)  (defimplementation frame-locals (n)
351    (let ((frame (nth-frame n))    (let ((frame (nth-frame n)))
         (*print-readably* nil)  
         (*print-pretty* t)  
         (*print-circle* t))  
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                (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 251  Return NIL if the symbol is unbound." Line 379  Return NIL if the symbol is unbound."
379    
380  (defimplementation return-from-frame (frame-number form)  (defimplementation return-from-frame (frame-number form)
381    (let* ((frame (nth-frame frame-number))    (let* ((frame (nth-frame frame-number))
382           (return-frame (dbg::find-frame-for-return frame))           (return-frame (dbg::find-frame-for-return frame)))
          (form (from-string form)))  
383      (dbg::dbg-return-from-call-frame frame form return-frame      (dbg::dbg-return-from-call-frame frame form return-frame
384                                       dbg::*debugger-stack*)))                                       dbg::*debugger-stack*)))
385    
# Line 260  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    (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  ;;; Definition finding  ;;; Definition finding
397    
398  (defun name-source-location (name)  (defun frame-location (dspec callee-name)
399    (first (name-source-locations name)))    (let ((infos (dspec:find-dspec-locations dspec)))
400        (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  (defun name-source-locations (name)  (defimplementation find-definitions (name)
412    (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))    (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
413      (cond ((not locations)      (loop for (dspec location) in locations
414             (list :error (format nil "Cannot find source for ~S" name)))            collect (list dspec (make-dspec-location dspec location)))))
           (t  
            (loop for (dspec location) in locations  
                  collect (make-dspec-location dspec location))))))  
   
 (defimplementation find-function-locations (fname)  
   (name-source-locations (from-string fname)))  
415    
416    
417  ;;; Compilation  ;;; Compilation
418    
419  (defimplementation compile-file-for-emacs (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 306  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 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))
          (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    
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  (defimplementation who-calls (function-name)  
657    (lookup-xrefs #'hcl:who-calls function-name))  (defxref who-calls      hcl:who-calls)
658    (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
659  (defimplementation who-references (variable)  (defxref calls-who      hcl:calls-who)
660    (lookup-xrefs #'hcl:who-references variable))  (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  (defimplementation who-binds (variable)  ;;; Inspector
   (lookup-xrefs #'hcl:who-binds variable))  
   
 (defimplementation 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)))  
701    
702  (defimplementation list-callers (symbol-name)  (defmethod emacs-inspect ((o t))
703    (lookup-xrefs #'hcl:who-calls symbol-name))    (lispworks-inspect o))
704    
705  (defimplementation list-callees (symbol-name)  (defmethod emacs-inspect ((o function))
706    (lookup-xrefs #'hcl:calls-who symbol-name))    (lispworks-inspect o))
707    
708  ;;; Inspector  ;; 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  (defmethod inspected-parts (o)  (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 474  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.28  
changed lines
  Added in v.1.128

  ViewVC Help
Powered by ViewVC 1.1.5