/[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.40 by heller, Fri Apr 30 06:32:24 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        #-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 52  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 ()              (make-instance 'comm:socket-stream
89    (set-sigint-handler)                             :socket fd
90    (let ((lw:*handle-warn-on-redefinition* :warn))                             :direction :io
91      (defmethod stream:stream-soft-force-output  ((o comm:socket-stream))                             :read-timeout timeout
92        (force-output o))                             :element-type '(unsigned-byte 8))
93      (defmethod stream:stream-soft-force-output ((o slime-output-stream))              external-format)))))
94        (force-output o))  
95      (defmethod env-internals:environment-display-notifier  (defun make-flexi-stream (stream external-format)
96          (env &key restarts condition)    (unless (member :flexi-streams *features*)
97        (declare (ignore restarts))      (error "Cannot use external format ~A without having installed flexi-streams in the inferior-lisp."
98        (funcall (find-symbol (string :swank-debugger-hook) :swank)             external-format))
99                 condition *debugger-hook*))))    (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 88  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    
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 103  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 125  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 144  Return NIL if the symbol is unbound." Line 208  Return NIL if the symbol is unbound."
208                            (not (generic-function-p (fdefinition symbol))))                            (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 152  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 :generic-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 (fdefinition symbol)))           (describe (fdefinition symbol)))
233          (t (format t "~S is not fbound" symbol))))          (t (format t "~S is not fbound" symbol))))
# Line 176  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*                   :io-bindings io-bindings
253             (dbg::frame-next                   :debugger-hoook hook))
254              (dbg::frame-next  
255               (dbg::frame-next  (defmethod env-internals:environment-display-notifier
256                (dbg::debugger-stack-current-frame dbg::*debugger-stack*))))))      ((env slime-env) &key restarts condition)
257        (funcall fn))))    (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    (cond ((or (dbg::call-frame-p frame)    (cond ((or (dbg::call-frame-p frame)
# Line 200  Return NIL if the symbol is unbound." Line 289  Return NIL if the symbol is unbound."
289          ((dbg::open-frame-p frame) dbg:*print-open-frames*)          ((dbg::open-frame-p frame) dbg:*print-open-frames*)
290          (t nil)))          (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 217  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      (let ((*break-on-signals* nil))
332      (mapcar (lambda (arg)      (mapcar (lambda (arg)
333                (handler-case (dbg::dbg-eval arg frame)                (case arg
334                  (error (format nil "<~A>" arg))))                  ((&rest &optional &key) arg)
335              (dbg::call-frame-arglist frame)))                  (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 229  Return NIL if the symbol is unbound." Line 344  Return NIL if the symbol is unbound."
344                   (frame-actual-args 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 ((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 267  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  (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 310  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)
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 1)))         (make-location `(:buffer ,buffer)
593        (symbol `(:error ,(format nil "Cannot resolve location: ~S" location)))                        (dspec-function-name-position dspec `(:offset ,offset 0))
594        ((satisfies emacs-buffer-location-p)                        hints)))))
595         (destructuring-bind (_ buffer offset string) location  
596           (declare (ignore _ string))  (defun make-dspec-progenitor-location (dspec location)
597           (make-location `(:buffer ,buffer)    (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
598                          (dspec-buffer-position dspec offset)))))))      (make-dspec-location
599         (if canon-dspec
600             (if (dspec:local-dspec-p canon-dspec)
601                 (dspec:dspec-progenitor canon-dspec)
602               canon-dspec)
603           nil)
604         location)))
605    
606  (defun signal-error-data-base (database 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         (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         tmpname)                       (setq dspec::*location* (list ,@location)))
647        (signal-error-data-base compiler::*error-database* location)                    s))
648        (signal-undefined-functions compiler::*unknown-functions* location))))           (write-string string s))
649           tmpname))))
650    
651  ;;; xref  ;;; xref
652    
# Line 399  Return NIL if the symbol is unbound." Line 655  Return NIL if the symbol is unbound."
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 list-callees   hcl:calls-who)  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
659    (defxref calls-who      hcl:calls-who)
660    (defxref list-callers   list-callers-internal)
661    ;; (defxref list-callees   list-callees-internal)
662    
663    (defun list-callers-internal (name)
664      (let ((callers (make-array 100
665                                 :fill-pointer 0
666                                 :adjustable t)))
667        (hcl:sweep-all-objects
668         #'(lambda (object)
669             (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
670                        #-Harlequin-PC-Lisp (sys::callablep object)
671                        (system::find-constant$funcallable name object))
672               (vector-push-extend object callers))))
673        ;; Delay dspec:object-dspec until after sweep-all-objects
674        ;; to reduce allocation problems.
675        (loop for object across callers
676              collect (if (symbolp object)
677                          (list 'function object)
678                          (or (dspec:object-dspec object) object)))))
679    
680  ;; only for lispworks 4.2 and above  ;; only for lispworks 4.2 and above
681  #-lispworks4.1  #-lispworks4.1
# Line 413  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
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    (let ((mp:*process-initial-bindings*    (mp:process-run-function name () fn))
760           (remove (find-package :cl)  
761                   mp:*process-initial-bindings*  (defvar *id-lock* (mp:make-lock))
762                   :key (lambda (x) (symbol-package (car x))))))  (defvar *thread-id-counter* 0)
763      (mp:process-run-function name () fn)))  
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))
# Line 468  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.40  
changed lines
  Added in v.1.128

  ViewVC Help
Powered by ViewVC 1.1.5