/[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.59 by mbaringer, Fri Sep 17 12:50:41 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))
    stream:fundamental-character-input-stream  
    stream:stream-read-char  
    stream:stream-listen  
    stream:stream-unread-char  
    stream:stream-clear-input  
    stream:stream-line-column  
    ))  
   
 (import-to-swank-mop  
  '( ;; classes  
    cl:standard-generic-function  
    clos:standard-slot-definition  
    cl:method  
    cl:standard-class  
    ;; standard-class readers  
    clos:class-default-initargs  
    clos:class-direct-default-initargs  
    clos:class-direct-slots  
    clos:class-direct-subclasses  
    clos:class-direct-superclasses  
    clos:class-finalized-p  
    cl:class-name  
    clos:class-precedence-list  
    clos:class-prototype  
    clos:class-slots  
    clos:specializer-direct-methods  
    ;; generic function readers  
    clos:generic-function-argument-precedence-order  
    clos:generic-function-declarations  
    clos:generic-function-lambda-list  
    clos:generic-function-methods  
    clos:generic-function-method-class  
    clos:generic-function-method-combination  
    clos:generic-function-name  
    ;; method readers  
    clos:method-generic-function  
    clos:method-function  
    clos:method-lambda-list  
    clos:method-specializers  
    clos:method-qualifiers  
    ;; slot readers  
    clos:slot-definition-allocation  
    clos:slot-definition-initargs  
    clos:slot-definition-initform  
    clos:slot-definition-initfunction  
    clos:slot-definition-name  
    clos:slot-definition-type  
    clos:slot-definition-readers  
    clos:slot-definition-writers))  
21    
22  (defun swank-mop:slot-definition-documentation (slot)  (defun swank-mop:slot-definition-documentation (slot)
23    (documentation slot t))    (documentation slot t))
24    
25  ;;;; lispworks doesn't have the eql-specializer class, it represents  (defun swank-mop:compute-applicable-methods-using-classes (gf classes)
26  ;;;; them as a list of `(EQL ,OBJECT)    (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)  (deftype swank-mop:eql-specializer () 'cons)
31    
32  (defun swank-mop:eql-specializer-object (eql-spec)  (defun swank-mop:eql-specializer-object (eql-spec)
33    (second eql-spec))    (second eql-spec))
34    
35  (when (fboundp 'dspec::define-dspec-alias)  (eval-when (:compile-toplevel :execute :load-toplevel)
36    (dspec::define-dspec-alias defimplementation (name args &rest body)    (defvar *original-defimplementation* (macro-function 'defimplementation))
37      `(defmethod ,name ,args ,@body)))    (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 93  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 108  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 148  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 188  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 224  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 244  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 272  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 330  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 355  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)))
# Line 375  Return NIL if the symbol is unbound." Line 420  Return NIL if the symbol is unbound."
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)  (defimplementation call-with-compilation-hooks (function)
456    ;; #'pray instead of #'handler-bind    (let ((compiler::*error-database* '())
457    (funcall function))          (*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 408  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 440  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    (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  #-(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 468  Return NIL if the symbol is unbound." Line 558  Return NIL if the symbol is unbound."
558                (check-dspec form))))))                (check-dspec form))))))
559    
560  (defun dspec-file-position (file dspec)  (defun dspec-file-position (file dspec)
561    (with-open-file (stream file)    (let* ((*compile-file-pathname* (pathname file))
562      (let ((pos           (*compile-file-truename* (truename *compile-file-pathname*))
563             #-(or lispworks4.1 lispworks4.2)           (*load-pathname* *compile-file-pathname*)
564             (dspec-stream-position stream dspec)))           (*load-truename* *compile-file-truename*))
565        (if pos      (with-open-file (stream file)
566            (list :position (1+ pos) t)        (let ((pos
567            (dspec-buffer-position dspec 1)))))               #-(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    (etypecase location    (etypecase location
579      ((or pathname string)      ((or pathname string)
580       (multiple-value-bind (file err)       (multiple-value-bind (file err)
# Line 488  Return NIL if the symbol is unbound." Line 582  Return NIL if the symbol is unbound."
582         (if err         (if err
583             (list :error (princ-to-string err))             (list :error (princ-to-string err))
584             (make-location `(:file ,file)             (make-location `(:file ,file)
585                            (dspec-file-position file dspec)))))                            (dspec-file-position file dspec)
586                              hints))))
587      (symbol      (symbol
588       `(:error ,(format nil "Cannot resolve location: ~S" location)))       `(:error ,(format nil "Cannot resolve location: ~S" location)))
589      ((satisfies emacs-buffer-location-p)      ((satisfies emacs-buffer-location-p)
590       (destructuring-bind (_ buffer offset string) location       (destructuring-bind (_ buffer offset string) location
591         (declare (ignore _ string))         (declare (ignore _ string))
592         (make-location `(:buffer ,buffer)         (make-location `(:buffer ,buffer)
593                        (dspec-buffer-position dspec offset))))))                        (dspec-function-name-position dspec `(:offset ,offset 0))
594                          hints)))))
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 507  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 directory)  (defimplementation swank-compile-string (string &key buffer position filename
635    (declare (ignore directory))                                           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 547  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 565  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 579  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  (defclass lispworks-inspector (inspector)  (defmethod emacs-inspect ((o t))
703    ())    (lispworks-inspect o))
704    
705  (defimplementation make-default-inspector ()  (defmethod emacs-inspect ((o function))
706    (make-instance 'lispworks-inspector))    (lispworks-inspect o))
707    
708  (defimplementation inspect-for-emacs ((o t) (inspector lispworks-inspector))  ;; FIXME: slot-boundp-using-class in LW works with names so we can't
709    (declare (ignore inspector))  ;; 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 "A value."              (append
718              `("Type: " (:value ,type)               (label-value-line "Type" type)
719                (:newline)               (loop for name in names
               "Getter: " (:value ,_getter)  
               (:newline)  
               "Setter: " (:value ,_setter)  
               (:newline)  
               "Slots:"  
               (:newline)  
               ,@(loop  
                    for name in names  
720                     for value in values                     for value in values
721                     collect `(:value ,name)                     append (label-value-line name value)))))
                    collect " = "  
                    collect `(:value ,value)  
                    collect `(:newline))))))  
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 673  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-if (test &optional timeout)
816      (let* ((mbox (mailbox mp:*current-process*))
817             (lock (mailbox.mutex mbox)))
818        (assert (or (not timeout) (eq timeout t)))
819        (loop
820         (check-slime-interrupts)
821         (mp:with-lock (lock "receive-if/try")
822           (let* ((q (mailbox.queue mbox))
823                  (tail (member-if test q)))
824             (when tail
825               (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
826               (return (car tail)))))
827         (when (eq timeout t) (return (values nil t)))
828         (mp:process-wait-with-timeout
829          "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
830    
831    (defimplementation send (thread message)
832      (let ((mbox (mailbox thread)))
833        (mp:with-lock ((mailbox.mutex mbox))
834          (setf (mailbox.queue mbox)
835                (nconc (mailbox.queue mbox) (list message))))))
836    
837    (defimplementation set-default-initial-binding (var form)
838      (setq mp:*process-initial-bindings*
839            (acons var `(eval (quote ,form))
840                   mp:*process-initial-bindings* )))
841    
842  (defimplementation receive ()  ;;; Some intergration with the lispworks environment
843    (mp:mailbox-read (mailbox mp:*current-process*)))  
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.59  
changed lines
  Added in v.1.128

  ViewVC Help
Powered by ViewVC 1.1.5