/[slime]/slime/swank-clisp.lisp
ViewVC logotype

Diff of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.24 by mbaringer, Fri Mar 5 14:26:14 2004 UTC revision 1.24.2.2 by heller, Tue Mar 9 12:11:05 2004 UTC
# Line 22  Line 22 
22  ;;;  ;;;
23  ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/  ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
24    
25  (in-package "SWANK")  (in-package :swank-backend)
26    
27  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
28    (use-package "SOCKET")    (use-package "SOCKET")
# Line 45  Line 45 
45         (unwind-protect         (unwind-protect
46              (progn ,@body)              (progn ,@body)
47           (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))           (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
48    
49    ;; XXX currently only works in CVS version. 2.32 breaks.
50  ;; #+linux  ;; #+linux
51  ;; (defmethod call-without-interrupts (fn)  ;; (defmethod call-without-interrupts (fn)
52  ;;   (with-blocked-signals (#.linux:SIGINT) (funcall fn)))  ;;   (with-blocked-signals (#.linux:SIGINT) (funcall fn)))
# Line 64  Line 65 
65    
66  ;;; TCP Server  ;;; TCP Server
67    
 (setq *swank-in-background* nil)  
   
68  (defimplementation create-socket (host port)  (defimplementation create-socket (host port)
69    (declare (ignore host))    (declare (ignore host))
70    (socket:socket-server port))    (socket:socket-server port))
# Line 84  Line 83 
83                                            :charset 'charset:iso-8859-1                                            :charset 'charset:iso-8859-1
84                                            :line-terminator :unix)))                                            :line-terminator :unix)))
85    
 (defvar *sigio-handlers* '()  
   "List of (key . fn) pairs to be called on SIGIO.")  
   
 (defun sigio-handler (signal)  
   (mapc (lambda (handler) (funcall (cdr handler))) *sigio-handlers*))  
   
 ;(trace sigio-handler)  
   
 (defvar *saved-sigio-handler*)  
   
 #+(or)  
 (progn  
   (defun set-sigio-handler ()  
     (setf *saved-sigio-handler*  
           (linux:set-signal-handler linux:SIGIO  
                                     (lambda (signal) (sigio-handler signal))))  
     (let* ((action (linux:signal-action-retrieve linux:SIGIO))  
            (flags (linux:sa-flags action)))  
       (setf (linux:sa-flags action) (logior flags linux:SA_NODEFER))  
       (linux:signal-action-install linux:SIGIO action)))  
   
   (defimplementation add-input-handler (socket fn)  
     (set-sigio-handler)  
     (let ((fd (socket:socket-stream-handle socket)))  
       (format *debug-io* "Adding input handler: ~S ~%" fd)  
       ;; XXX error checking  
       (linux:fcntl3l fd linux:F_SETOWN (getpid))  
       (linux:fcntl3l fd linux:F_SETFL linux:O_ASYNC)  
       (push (cons fd fn) *sigio-handlers*)))  
   
   (defimplementation remove-input-handlers (socket)  
     (let ((fd (socket:socket-stream-handle socket)))  
       (remove-sigio-handler fd)  
       (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)))  
     (close socket))  
   )  
   
86  ;;; Swank functions  ;;; Swank functions
87    
88  (defimplementation arglist-string (fname)  (defimplementation arglist (fname)
89    (format-arglist fname #'ext:arglist))    (ext:arglist fname))
90    
91  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
92    (ext:expand-form form))    (ext:expand-form form))
# Line 141  Return NIL if the symbol is unbound." Line 103  Return NIL if the symbol is unbound."
103        (when (fboundp symbol)        (when (fboundp symbol)
104          (if (macro-function symbol)          (if (macro-function symbol)
105              (setf (getf result :macro) (doc 'function))              (setf (getf result :macro) (doc 'function))
106            (setf (getf result :function) (doc 'function))))              (setf (getf result :function) (doc 'function))))
107        (maybe-push :variable (when (boundp symbol) (doc 'variable)))        (maybe-push :variable (when (boundp symbol) (doc 'variable)))
108        (maybe-push :class (when (find-class symbol nil)        (maybe-push :class (when (find-class symbol nil)
109                             (doc 'type))) ;this should be fixed                             (doc 'type))) ;this should be fixed
110        result)))        result)))
111    
112    (defimplementation describe-definition (symbol namespace)
113      (ecase namespace
114        (:variable (describe symbol))
115        (:macro (describe (macro-function symbol)))
116        (:function (describe (symbol-function symbol)))
117        (:class (describe (find-class symbol)))))
118    
119  (defun fspec-pathname (symbol &optional type)  (defun fspec-pathname (symbol &optional type)
120    (declare (ignore type))    (declare (ignore type))
121    (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))    (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
# Line 160  Return NIL if the symbol is unbound." Line 129  Return NIL if the symbol is unbound."
129    
130  (defun find-multiple-definitions (fspec)  (defun find-multiple-definitions (fspec)
131    (list `(,fspec t)))    (list `(,fspec t)))
132  (fspec-pathname 'disassemble)  
133  (defun find-definition-in-file (fspec type file)  (defun find-definition-in-file (fspec type file)
134    (declare (ignore fspec type file))    (declare (ignore fspec type file))
135    ;; FIXME    ;; FIXME
136    0)    0)
137    
138    (defun find-fspec-location (fspec type)
139      (let ((file (fspec-pathname fspec type)))
140        (etypecase file
141          (pathname
142           (let ((start (find-definition-in-file fspec type file)))
143             (multiple-value-bind (truename c) (ignore-errors (truename file))
144               (cond (truename
145                      (make-location (list :file (namestring truename))
146                                     (list :function-name (string fspec))))
147                     (t (list :error (princ-to-string c)))))))
148          ((member :top-level)
149           (list :error (format nil "Defined at toplevel: ~A" fspec)))
150          (null
151           (list :error (format nil "Unkown source location for ~A" fspec))))))
152    
153  (defun fspec-source-locations (fspec)  (defun fspec-source-locations (fspec)
154    (let ((defs (find-multiple-definitions fspec)))    (let ((defs (find-multiple-definitions fspec)))
155      (let ((locations '()))      (loop for (fspec type) in defs
156        (loop for (fspec type) in defs do            collect (list fspec (find-fspec-location fspec type)))))
157              (let ((file (fspec-pathname fspec type)))  
158                (etypecase file  
159                  (pathname  (defimplementation find-definitions (name)
160                   (let ((start (find-definition-in-file fspec type file)))    (loop for location in (fspec-source-locations name)
161                     (push (make-location          collect (list name location)))
                           (list :file (namestring (truename file)))  
                           (if start  
                               (list :position (1+ start))  
                               (list :function-name (string fspec))))  
                          locations)))  
                 ((member :top-level)  
                  (push (list :error (format nil "Defined at toplevel: ~A"  
                                             fspec))  
                        locations))  
                 (null  
                  (push (list :error (format nil  
                                             "Unkown source location for ~A"  
                                             fspec))  
                        locations))  
                 )))  
       locations)))  
   
 (defimplementation find-function-locations (symbol-name)  
   (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)  
     (cond ((not foundp)  
            (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))  
           ((macro-function symbol)  
            (fspec-source-locations symbol))  
           ((special-operator-p symbol)  
            (list (list :error (format nil "~A is a special-operator" symbol))))  
           ((fboundp symbol)  
            (fspec-source-locations symbol))  
           (t (list (list :error  
                          (format nil "Symbol not fbound: ~A" symbol-name))))  
           )))  
162    
163  (defvar *sldb-topframe*)  (defvar *sldb-topframe*)
164  (defvar *sldb-botframe*)  (defvar *sldb-botframe*)
165  (defvar *sldb-source*)  (defvar *sldb-source*)
 (defvar *sldb-restarts*)  
166  (defvar *sldb-debugmode* 4)  (defvar *sldb-debugmode* 4)
167    
168  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
# Line 224  Return NIL if the symbol is unbound." Line 177  Return NIL if the symbol is unbound."
177            (sys::frame-down-1            (sys::frame-down-1
178             (sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*)             (sys::frame-up-1 sys::*frame-limit1* sys::*debug-mode*)
179             sys::*debug-mode*))             sys::*debug-mode*))
180           (*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*))           (*sldb-botframe* (sys::frame-up *sldb-topframe* sys::*debug-mode*)))
          (*sldb-restarts* (compute-restarts *swank-debugger-condition*)))  
181      (funcall debugger-loop-fn)))      (funcall debugger-loop-fn)))
182    
 (defun format-restarts-for-emacs ()  
   (loop for restart in *sldb-restarts*  
         collect (list (princ-to-string (restart-name restart))  
                       (princ-to-string restart))))  
   
183  (defun nth-frame (index)  (defun nth-frame (index)
184    (loop for frame = *sldb-topframe* then (sys::frame-up-1 frame    (loop for frame = *sldb-topframe* then (sys::frame-up-1 frame
185                                                            sys::*debug-mode*)                                                            sys::*debug-mode*)
# Line 240  Return NIL if the symbol is unbound." Line 187  Return NIL if the symbol is unbound."
187          never (eq frame *sldb-botframe*)          never (eq frame *sldb-botframe*)
188          finally (return frame)))          finally (return frame)))
189    
190  (defun compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
191    (let ((end (or end most-positive-fixnum)))    (let ((end (or end most-positive-fixnum)))
192      (loop for f = (nth-frame start)      (loop for f = (nth-frame start)
193            then (sys::frame-up-1 f sys::*debug-mode*)            then (sys::frame-up-1 f sys::*debug-mode*)
# Line 248  Return NIL if the symbol is unbound." Line 195  Return NIL if the symbol is unbound."
195            until (eq f *sldb-botframe*)            until (eq f *sldb-botframe*)
196            collect f)))            collect f)))
197    
198  (defimplementation backtrace (start-frame-number end-frame-number)  (defimplementation print-frame (frame stream)
199    (flet ((format-frame (f i)    (write-string (string-left-trim '(#\Newline)
200             (print-with-frame-label                                    (with-output-to-string (stream)
201              i (lambda (s)                                      (sys::describe-frame stream frame)))
202                  (princ (string-left-trim                  stream))
                         '(#\Newline)  
                         (with-output-to-string (stream)  
                           (sys::describe-frame stream f)))  
                        s)))))  
     (loop for i from start-frame-number  
           for f in (compute-backtrace start-frame-number end-frame-number)  
           collect (list i (format-frame f i)))))  
203    
204  (defimplementation eval-in-frame (form frame-number)  (defimplementation eval-in-frame (form frame-number)
205    (sys::eval-at (nth-frame frame-number) form))    (sys::eval-at (nth-frame frame-number) form))
# Line 309  Return NIL if the symbol is unbound." Line 249  Return NIL if the symbol is unbound."
249    nil)    nil)
250    
251  (defimplementation return-from-frame (index form)  (defimplementation return-from-frame (index form)
252    (sys::return-from-eval-frame (nth-frame index) (from-string form)))    (sys::return-from-eval-frame (nth-frame index) form))
253    
254  (defimplementation restart-frame (index)  (defimplementation restart-frame (index)
255    (sys::redo-eval-frame (nth-frame index)))    (sys::redo-eval-frame (nth-frame index)))
# Line 318  Return NIL if the symbol is unbound." Line 258  Return NIL if the symbol is unbound."
258    (list :error (format nil "Cannot find source for frame: ~A"    (list :error (format nil "Cannot find source for frame: ~A"
259                         (nth-frame index))))                         (nth-frame index))))
260    
 (defimplementation debugger-info-for-emacs (start end)  
   (list (debugger-condition-for-emacs)  
         (format-restarts-for-emacs)  
         (backtrace start end)))  
   
 (defun nth-restart (index)  
   (nth index *sldb-restarts*))  
   
 (defslimefun invoke-nth-restart (index)  
   (invoke-restart-interactively (nth-restart index)))  
   
 (defslimefun sldb-abort ()  
   (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))  
   
261  ;;; Profiling  ;;; Profiling
262    
263  (defimplementation profile (fname)  (defimplementation profile (fname)
# Line 371  Return NIL if the symbol is unbound." Line 297  Return NIL if the symbol is unbound."
297          ,@body)          ,@body)
298         (sys::simple-end-of-file () nil)))))         (sys::simple-end-of-file () nil)))))
299    
300    (defvar *orig-c-warn* (symbol-function 'system::c-warn))
301    (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
302    (defvar *orig-c-error* (symbol-function 'system::c-error))
303    (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
304    
305    (defmacro dynamic-flet (names-functions &body body)
306      "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
307    Temporary the symbol slot of NAME in the dynamic extend of BODY to FUNCTION."
308      `(ext:letf* ,(loop for (name function) in names-functions
309                         collect `((symbol-function ',name) ,function))
310        ,@body))
311    
312    (defun compiler-note-location ()
313      "Return the current compiler location of the compiler."
314      (let ((lineno1 sys::*compile-file-lineno1*)
315            (lineno2 sys::*compile-file-lineno2*)
316            (file sys::*compile-file-truename*))
317        (cond ((and file lineno1 lineno2)
318               `(:location (:file ,(namestring file)) (:line ,lineno1)))
319              (*buffer-name*
320               `(:location (:buffer ,*buffer-name*) (:position ,*buffer-offset*)))
321              (t
322               (list :error "No error location available")))))
323    
324    (defun signal-compiler-warning (cstring args severity orig-fn)
325      (signal (make-condition 'compiler-condition
326                              :severity severity
327                              :message (apply #'format nil cstring args)
328                              :location (compiler-note-location)))
329      (apply orig-fn cstring args))
330    
331    (defun c-warn (cstring &rest args)
332      (signal-compiler-warning cstring args :warning *orig-c-warn*))
333    
334    (defun c-style-warn (cstring &rest args)
335      (dynamic-flet ((sys::c-warn *orig-c-warn*))
336        (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
337    
338    (defun c-error (cstring &rest args)
339      (signal-compiler-warning cstring args :error *orig-c-error*))
340    
341  (defimplementation call-with-compilation-hooks (function)  (defimplementation call-with-compilation-hooks (function)
342    (handler-bind ((compiler-condition #'handle-notification-condition))    (handler-bind ((warning #'handle-notification-condition))
343      (funcall function)))      (dynamic-flet ((system::c-warn #'c-warn)
344                       (system::c-style-warn #'c-style-warn)
345                       (system::c-error #'c-error))
346          (funcall function))))
347    
348  (defun handle-notification-condition (condition)  (defun handle-notification-condition (condition)
349    "Handle a condition caused by a compiler warning."    "Handle a condition caused by a compiler warning."
350    (declare (ignore condition)))    (signal (make-condition 'compiler-condition
351                              :original-condition condition
352                              :severity :warning
353                              :message (princ-to-string condition)
354                              :location (compiler-note-location))))
355    
356  (defvar *buffer-name* nil)  (defvar *buffer-name* nil)
357  (defvar *buffer-offset*)  (defvar *buffer-offset*)
358    
359  (defvar *compiler-note-line-regexp*  (defimplementation swank-compile-file (filename load-p)
   (regexp:regexp-compile  
    "^(WARNING|ERROR) .* in lines ([0-9]+)\\.\\.[0-9]+ :$"  
    :extended t))  
   
 (defun split-compiler-note-line (line)  
   (multiple-value-bind (all head tail)  
       (regexp:regexp-exec *compiler-note-line-regexp* line)  
     (declare (ignore all))  
     (if head  
         (list (let ((*package* (find-package :keyword)))  
                 (read-from-string (regexp:match-string line head)))  
               (read-from-string (regexp:match-string line tail)))  
         (list nil line))))  
   
 ;;; Ugly but essentially working.  
 ;;; TODO: Do something with the summary about undefined functions etc.  
   
 (defimplementation compile-file-for-emacs (filename load-p)  
360    (with-compilation-hooks ()    (with-compilation-hooks ()
361      (multiple-value-bind (fas-file w-p f-p)      (with-compilation-unit ()
362          (compile-file-frobbing-notes (filename)        (let ((fasl-file (compile-file filename)))
363            (read-line)                   ;""          (when (and load-p fasl-file)
364            (read-line)                   ;"Compiling file ..."            (load fasl-file))
365            (loop          nil))))
              with condition  
              for (severity message) = (split-compiler-note-line (read-line))  
              until (and (stringp message) (string= message ""))  
              if severity  
              do (when condition  
                   (signal condition))  
              (setq condition  
                    (make-condition 'compiler-condition  
                                    :severity severity  
                                    :message ""  
                                    :location `(:location (:file ,filename)  
                                                          (:line ,message))))  
              else do (setf (message condition)  
                            (format nil "~a~&~a" (message condition) message))  
              finally (when condition  
                        (signal condition))))  
       ;; w-p = errors + warnings, f-p = errors + warnings - style warnings,  
       ;; where a result of 0 is replaced by NIL.  It follows that w-p  
       ;; is non-NIL iff there was any note whatsoever and that f-p is  
       ;; non-NIL iff there was anything more severe than a style  
       ;; warning.  This is completely ANSI compliant.  
       (declare (ignore w-p f-p))  
       (if (and fas-file load-p)  
           (load fas-file)  
           fas-file))))  
366    
367  (defimplementation compile-string-for-emacs (string &key buffer position)  (defimplementation swank-compile-string (string &key buffer position)
368    (with-compilation-hooks ()    (with-compilation-hooks ()
369      (let ((*package* *buffer-package*)      (let ((*buffer-name* buffer)
           (*buffer-name* buffer)  
370            (*buffer-offset* position))            (*buffer-offset* position))
371        (eval (from-string        (funcall (compile nil (read-from-string
372               (format nil "(funcall (compile nil '(lambda () ~A)))"                               (format nil "(CL:LAMBDA () ~A)" string)))))))
                      string))))))  
373    
374  ;;; Portable XREF from the CMU AI repository.  ;;; Portable XREF from the CMU AI repository.
375    
376  (setq xref::*handle-package-forms* '(cl:in-package))  (setq xref::*handle-package-forms* '(cl:in-package))
377    
378  (defun lookup-xrefs (finder name)  (defmacro defxref (name function)
379    (xref-results-for-emacs (funcall finder (from-string name))))    `(defimplementation ,name (name)
380        (xref-results (,function name))))
381  (defimplementation who-calls (function-name)  
382    (lookup-xrefs #'xref:list-callers function-name))  (defxref who-calls      xref:list-callers)
383    (defxref who-references xref:list-readers)
384  (defimplementation who-references (variable)  (defxref who-binds      xref:list-setters)
385    (lookup-xrefs #'xref:list-readers variable))  (defxref who-sets       xref:list-setters)
386    (defxref list-callers   xref:list-callers)
387  (defimplementation who-binds (variable)  (defxref list-callees   xref:list-callees)
   (lookup-xrefs #'xref:list-setters variable))  
   
 (defimplementation who-sets (variable)  
   (lookup-xrefs #'xref:list-setters variable))  
   
 (defimplementation list-callers (symbol-name)  
   (lookup-xrefs #'xref:who-calls symbol-name))  
   
 (defimplementation list-callees (symbol-name)  
   (lookup-xrefs #'xref:list-callees symbol-name))  
388    
389  (defun xref-results-for-emacs (fspecs)  (defun xref-results (fspecs)
390    (let ((xrefs '()))    (let ((xrefs '()))
391      (dolist (fspec fspecs)      (dolist (fspec fspecs)
392        (dolist (location (fspec-source-locations fspec))        (dolist (location (fspec-source-locations fspec))
393          (push (cons (to-string fspec) location) xrefs)))          (push (list fspec location) xrefs)))
394      (group-xrefs xrefs)))      xrefs))
395    
396  (when (find-package :swank-loader)  (when (find-package :swank-loader)
397    (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))    (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
# Line 530  Return NIL if the symbol is unbound." Line 449  Return NIL if the symbol is unbound."
449                  (dotimes (i count)                  (dotimes (i count)
450                    (multiple-value-bind (value name)                    (multiple-value-bind (value name)
451                        (funcall (sys::insp-nth-slot inspection) i)                        (funcall (sys::insp-nth-slot inspection) i)
452                      (push (cons (to-string (or name i)) value)                      (push (cons (princ-to-string (or name i)) value)
453                            pairs)))                            pairs)))
454                  (nreverse pairs))))))                  (nreverse pairs))))))
455    
456  ;;; Local Variables:  ;;; Local Variables:
457  ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)  ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
458    ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
459  ;;; End:  ;;; End:

Legend:
Removed from v.1.24  
changed lines
  Added in v.1.24.2.2

  ViewVC Help
Powered by ViewVC 1.1.5