/[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.49 by heller, Wed Jun 30 21:45:07 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  (when (fboundp 'dspec::define-form-parser)  ;; them as a list of `(EQL ,OBJECT)
30    (dspec::define-form-parser defimplementation (name args &rest body)  (deftype swank-mop:eql-specializer () 'cons)
31      `(defmethod ,name ,args ,@body)))  
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 41  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        #-lispworks4.1(comm::create-tcp-socket-for-service port :address host)        #-(or lispworks4.1 (and macosx lispworks4.3))
58        #+lispworks4.1(comm::create-tcp-socket-for-service port)        (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 56  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  (defun set-sigint-handler ()                            :socket fd
83    ;; Set SIGINT handler on Swank request handler thread.                            :direction :io
84    #-win32                            :read-timeout timeout
85    (sys::set-signal-handler +sigint+                            :element-type 'base-char))
86                             (make-sigint-handler mp:*current-process*)))            (t
87               (make-flexi-stream
88  (defimplementation emacs-connected (stream)              (make-instance 'comm:socket-stream
89    (declare (ignore stream))                             :socket fd
90    (set-sigint-handler)                             :direction :io
91    (let ((lw:*handle-warn-on-redefinition* :warn))                             :read-timeout timeout
92      (defmethod stream:stream-soft-force-output  ((o comm:socket-stream))                             :element-type '(unsigned-byte 8))
93        (force-output o))              external-format)))))
94      (defmethod stream:stream-soft-force-output ((o slime-output-stream))  
95        (force-output o))  (defun make-flexi-stream (stream external-format)
96      (defmethod env-internals:environment-display-notifier    (unless (member :flexi-streams *features*)
97          (env &key restarts condition)      (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
98        (declare (ignore restarts))             external-format))
99        (funcall (find-symbol (string :swank-debugger-hook) :swank)    (funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
100                 condition *debugger-hook*))             stream
101      (defmethod env-internals:environment-display-debugger             :external-format
102          (env)             (apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
103        *debug-io*)))                    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 96  Line 135 
135      (declare (ignore args))      (declare (ignore args))
136      (mp:process-interrupt process #'sigint-handler)))      (mp:process-interrupt process #'sigint-handler)))
137    
138    (defun set-sigint-handler ()
139      ;; 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)  (defimplementation call-without-interrupts (fn)
153    (lw:without-interrupts (funcall fn)))    (lw:without-interrupts (funcall fn)))
154    
# Line 111  Line 164 
164    
165  ;;;; Documentation  ;;;; Documentation
166    
167  (defimplementation arglist (symbol)  (defimplementation arglist (symbol-or-function)
168    (let ((arglist (lw:function-lambda-list symbol)))    (let ((arglist (lw:function-lambda-list symbol-or-function)))
169      (etypecase arglist      (etypecase arglist
170        ((member :dont-know)        ((member :dont-know)
171         :not-available)         :not-available)
172        (list        (list
173         arglist))))         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    
# Line 133  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 169  Return NIL if the symbol is unbound." Line 225  Return NIL if the symbol is unbound."
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 (fdefinition symbol)))           (describe (fdefinition symbol)))
233          (t (format t "~S is not fbound" symbol))))          (t (format t "~S is not fbound" symbol))))
# Line 189  Return NIL if the symbol is unbound." Line 244  Return NIL if the symbol is unbound."
244    
245  ;;; Debugging  ;;; Debugging
246    
247    (defclass slime-env (env:environment)
248      ((debugger-hook :initarg :debugger-hoook)))
249    
250    (defun slime-env (hook io-bindings)
251      (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  (defvar *sldb-top-frame*)  (defvar *sldb-top-frame*)
278    
279  (defun interesting-frame-p (frame)  (defun interesting-frame-p (frame)
# Line 217  Return NIL if the symbol is unbound." Line 302  Return NIL if the symbol is unbound."
302    
303  (defun find-top-frame ()  (defun find-top-frame ()
304    "Return the most suitable top-frame for the debugger."    "Return the most suitable top-frame for the debugger."
305    (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)    (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
306                (nth-next-frame frame 1)))                    (nth-next-frame frame 1)))
307        ((and (dbg::call-frame-p frame)            ((or (null frame)             ; no frame found!
308              (eq (dbg::call-frame-function-name frame)                 (and (dbg::call-frame-p frame)
309                  'invoke-debugger))                      (eq (dbg::call-frame-function-name frame)
310         (nth-next-frame frame 1))))                          '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)  (defimplementation call-with-debugging-environment (fn)
316    (dbg::with-debugger-stack ()    (dbg::with-debugger-stack ()
# Line 240  Return NIL if the symbol is unbound." Line 328  Return NIL if the symbol is unbound."
328          (push frame backtrace)))))          (push frame backtrace)))))
329    
330  (defun frame-actual-args (frame)  (defun frame-actual-args (frame)
331    (mapcar (lambda (arg)    (let ((*break-on-signals* nil))
332              (handler-case (dbg::dbg-eval arg frame)      (mapcar (lambda (arg)
333                (error (format nil "<~A>" arg))))                (case arg
334            (dbg::call-frame-arglist frame)))                  ((&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)
# Line 271  Return NIL if the symbol is unbound." Line 363  Return NIL if the symbol is unbound."
363        (declare (ignore _n _s _l))        (declare (ignore _n _s _l))
364        value)))        value)))
365    
 (defimplementation frame-catch-tags (index)  
   (declare (ignore index))  
   nil)  
   
366  (defimplementation frame-source-location-for-emacs (frame)  (defimplementation frame-source-location-for-emacs (frame)
367    (let ((frame (nth-frame frame)))    (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 ((name (dbg::call-frame-function-name frame)))          (let ((dspec (dbg::call-frame-function-name frame))
371            (if name                (cname (and (dbg::call-frame-p callee)
372                (function-name-location name))))))                            (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 296  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 function-name-location (name)  (defun frame-location (dspec callee-name)
399    (let ((defs (find-definitions name)))    (let ((infos (dspec:find-dspec-locations dspec)))
400      (cond (defs (cadr (first defs)))      (cond (infos
401            (t (list :error (format nil "Source location not available for: ~S"             (destructuring-bind ((rdspec location) &rest _) infos
402                                    name))))))               (declare (ignore _))
403                 (let ((name (and callee-name (symbolp callee-name)
404                                  (string callee-name))))
405                   (make-dspec-location rdspec location
406                                        `(:call-site ,name)))))
407              (t
408               (list :error (format nil "Source location not available for: ~S"
409                                    dspec))))))
410    
411  (defimplementation find-definitions (name)  (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      (loop for (dspec location) in locations      (loop for (dspec location) in locations
414            collect (list dspec (make-dspec-location dspec location)))))            collect (list dspec (make-dspec-location dspec location)))))
415    
416    
417  ;;; Compilation  ;;; Compilation
418    
419  (defmacro with-swank-compilation-unit ((location &rest options) &body body)  (defmacro with-swank-compilation-unit ((location &rest options) &body body)
420    (lw:rebinding (location)    (lw:rebinding (location)
421      `(let ((compiler::*error-database* '()))      `(let ((compiler::*error-database* '()))
422         (with-compilation-unit ,options         (with-compilation-unit ,options
423           ,@body           (multiple-value-prog1 (progn ,@body)
424           (signal-error-data-base compiler::*error-database* ,location)             (signal-error-data-base compiler::*error-database*
425           (signal-undefined-functions compiler::*unknown-functions* ,location)))))                                     ,location)
426               (signal-undefined-functions compiler::*unknown-functions*
427  (defimplementation swank-compile-file (filename load-p)                                         ,location))))))
428    (with-swank-compilation-unit (filename)  
429      (compile-file filename :load load-p)))  (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 ()
460          (prog1 (funcall function)
461            (signal-error-data-base compiler::*error-database*)
462            (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 344  Return NIL if the symbol is unbound." Line 482  Return NIL if the symbol is unbound."
482                    :location location                    :location location
483                    :original-condition condition)))                    :original-condition condition)))
484    
485    (defvar *temp-file-format* '(:utf-8 :eol-style :lf))
486    
487  (defun compile-from-temp-file (string filename)  (defun compile-from-temp-file (string filename)
488    (unwind-protect    (unwind-protect
489         (progn         (progn
490           (with-open-file (s filename :direction :output :if-exists :supersede)           (with-open-file (s filename :direction :output
491                                         :if-exists :supersede
492                                         :external-format *temp-file-format*)
493    
494             (write-string string s)             (write-string string s)
495             (finish-output s))             (finish-output s))
496           (let ((binary-filename (compile-file filename :load t)))           (multiple-value-bind (binary-filename warnings? failure?)
497                 (compile-file filename :load t
498                               :external-format *temp-file-format*)
499               (declare (ignore warnings?))
500             (when binary-filename             (when binary-filename
501               (delete-file binary-filename))))               (delete-file binary-filename))
502               (not failure?)))
503      (delete-file filename)))      (delete-file filename)))
504    
505  (defun dspec-buffer-position (dspec offset)  (defun dspec-function-name-position (dspec fallback)
506    (etypecase dspec    (etypecase dspec
507      (cons (let ((name (dspec:dspec-primary-name dspec)))      (cons (let ((name (dspec:dspec-primary-name dspec)))
508              (typecase name              (typecase name
509                ((or symbol string)                ((or symbol string)
510                 (list :function-name (string name)))                 (list :function-name (string name)))
511                (t (list :position offset)))))                (t fallback))))
512      (null (list :position offset))      (null fallback)
513      (symbol (list :function-name (string dspec)))))      (symbol (list :function-name (string dspec)))))
514    
515  (defmacro with-fairly-standard-io-syntax (&body body)  (defmacro with-fairly-standard-io-syntax (&body body)
# Line 376  Return NIL if the symbol is unbound." Line 523  Return NIL if the symbol is unbound."
523                (*readtable* ,readtable))                (*readtable* ,readtable))
524            ,@body)))))            ,@body)))))
525    
526  #-(or lispworks-4.1 lispworks-4.2)      ; no dspec:parse-form-dspec prior to 4.3  (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)  (defun dspec-stream-position (stream dspec)
535    (with-fairly-standard-io-syntax    (with-fairly-standard-io-syntax
536      (loop (let* ((pos (file-position stream))      (loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
537                   (form (read stream nil '#1=#:eof)))                   (form (read stream nil '#1=#:eof)))
538              (when (eq form '#1#)              (when (eq form '#1#)
539                (return nil))                (return nil))
# Line 403  Return NIL if the symbol is unbound." Line 557  Return NIL if the symbol is unbound."
557                                    (return pos)))))))))                                    (return pos)))))))))
558                (check-dspec form))))))                (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         (let ((checked-filename (filename location)))         (declare (ignore _ string))
592           (make-location `(:file ,checked-filename)         (make-location `(:buffer ,buffer)
593                          #+(or lispworks-4.1 lispworks-4.2)                        (dspec-function-name-position dspec `(:offset ,offset 0))
594                          (dspec-buffer-position dspec 1)                        hints)))))
                         #-(or lispworks-4.1 lispworks-4.2)  
                         (with-open-file (stream checked-filename)  
                           (let ((position (dspec-stream-position stream dspec)))  
                             (if position  
                                 (list :position (1+ position) t)  
                               (dspec-buffer-position dspec 1)))))))  
       (symbol `(:error ,(format nil "Cannot resolve location: ~S" location)))  
       ((satisfies emacs-buffer-location-p)  
        (destructuring-bind (_ buffer offset string) location  
          (declare (ignore _ string))  
          (make-location `(:buffer ,buffer)  
                         (dspec-buffer-position dspec offset)))))))  
595    
596  (defun make-dspec-progenitor-location (dspec location)  (defun make-dspec-progenitor-location (dspec location)
597    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
# Line 448  Return NIL if the symbol is unbound." Line 603  Return NIL if the symbol is unbound."
603         nil)         nil)
604       location)))       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-progenitor-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-progenitor-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))
640           (tmpname (hcl:make-temp-file nil "lisp")))           (tmpname (hcl:make-temp-file nil "lisp")))
641      (with-swank-compilation-unit (location)      (with-swank-compilation-unit (location)
642        (compile-from-temp-file        (compile-from-temp-file
643         (format nil "~S~%~A" `(eval-when (:compile-toplevel)         (with-output-to-string (s)
644                                (setq dspec::*location* (list ,@location)))           (let ((*print-radix* t))
645                 string)             (print `(eval-when (:compile-toplevel)
646                         (setq dspec::*location* (list ,@location)))
647                      s))
648             (write-string string s))
649         tmpname))))         tmpname))))
650    
651  ;;; xref  ;;; xref
# Line 487  Return NIL if the symbol is unbound." Line 656  Return NIL if the symbol is unbound."
656    
657  (defxref who-calls      hcl:who-calls)  (defxref who-calls      hcl:who-calls)
658  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
659  (defxref list-callees   hcl:calls-who)  (defxref calls-who      hcl:calls-who)
660  (defxref list-callers   list-callers-internal)  (defxref list-callers   list-callers-internal)
661    ;; (defxref list-callees   list-callees-internal)
662    
663  (defun list-callers-internal (name)  (defun list-callers-internal (name)
664    (let ((callers (make-array 100    (let ((callers (make-array 100
# Line 505  Return NIL if the symbol is unbound." Line 675  Return NIL if the symbol is unbound."
675      (loop for object across callers      (loop for object across callers
676            collect (if (symbolp object)            collect (if (symbolp object)
677                        (list 'function object)                        (list 'function object)
678                        (dspec:object-dspec object)))))                        (or (dspec:object-dspec object) object)))))
679    
680  ;; only for lispworks 4.2 and above  ;; only for lispworks 4.2 and above
681  #-lispworks4.1  #-lispworks4.1
# Line 519  Return NIL if the symbol is unbound." Line 689  Return NIL if the symbol is unbound."
689      (xref-results (mapcar #'dspec:object-dspec methods))))      (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)             (cond (locs
694                      in (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              append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
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 #'cons names values))))               (label-value-line "Type" type)
719                 (loop for name in names
720                       for value in values
721                       append (label-value-line name value)))))
722    
723  ;;; Miscellaneous  ;;; Miscellaneous
724    
725  (defimplementation quit-lisp ()  (defimplementation quit-lisp ()
726    (lispworks:quit))    (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    (let ((mp:*process-initial-bindings*    (mp:process-run-function name () fn))
          (remove (find-package :cl)  
                  mp:*process-initial-bindings*  
                  :key (lambda (x) (symbol-package (car x))))))  
     (mp:process-run-function name () fn)))  
760    
761  (defvar *id-lock* (mp:make-lock))  (defvar *id-lock* (mp:make-lock))
762  (defvar *thread-id-counter* 0)  (defvar *thread-id-counter* 0)
# Line 592  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.49  
changed lines
  Added in v.1.128

  ViewVC Help
Powered by ViewVC 1.1.5