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

Diff of /slime/swank-allegro.lisp

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

revision 1.9 by heller, Sun Jan 18 07:19:03 2004 UTC revision 1.10 by heller, Tue Jan 20 23:40:48 2004 UTC
# Line 34  Line 34 
34    
35  ;;;; TCP Server  ;;;; TCP Server
36    
37  (defmethod create-socket (port)  (defimplementation create-socket (port)
38    (socket:make-socket :connect :passive :local-port port :reuse-address t))    (socket:make-socket :connect :passive :local-port port :reuse-address t))
39    
40  (defmethod local-port (socket)  (defimplementation local-port (socket)
41    (socket:local-port socket))    (socket:local-port socket))
42    
43  (defmethod close-socket (socket)  (defimplementation close-socket (socket)
44    (close socket))    (close socket))
45    
46  (defmethod accept-connection (socket)  (defimplementation accept-connection (socket)
47    (socket:accept-connection socket :wait t))    (socket:accept-connection socket :wait t))
48    
49  (defmethod emacs-connected ())  (defimplementation emacs-connected ())
50    
51  ;;;; Unix signals  ;;;; Unix signals
52    
53  (defmethod call-without-interrupts (fn)  (defimplementation call-without-interrupts (fn)
54    (excl:without-interrupts (funcall fn)))    (excl:without-interrupts (funcall fn)))
55    
56  (defmethod getpid ()  (defimplementation getpid ()
57    (excl::getpid))    (excl::getpid))
58    
59  ;;;; Misc  ;;;; Misc
60    
61  (defmethod arglist-string (fname)  (defimplementation arglist-string (fname)
62    (format-arglist fname #'excl:arglist))    (format-arglist fname #'excl:arglist))
63    
64  (defun apropos-symbols (string &optional external-only package)  (defun apropos-symbols (string &optional external-only package)
# Line 69  Line 69 
69                          (not (symbol-external-p sym)))))                          (not (symbol-external-p sym)))))
70               (apropos-list string package external-only t)))               (apropos-list string package external-only t)))
71    
72  (defmethod describe-symbol-for-emacs (symbol)  (defimplementation describe-symbol-for-emacs (symbol)
73    (let ((result '()))    (let ((result '()))
74      (flet ((doc (kind &optional (sym symbol))      (flet ((doc (kind &optional (sym symbol))
75               (or (documentation sym kind) :not-documented))               (or (documentation sym kind) :not-documented))
# Line 87  Line 87 
87                    (doc 'class)))                    (doc 'class)))
88        result)))        result)))
89    
90  (defmethod macroexpand-all (form)  (defimplementation macroexpand-all (form)
91    (excl::walk form))    (excl::walk form))
92    
93    (defimplementation describe-definition (symbol-name type)
94      (let ((symbol (from-string symbol-name)))
95        (ecase type
96          (:variable (print-description-to-string symbol))
97          ((:function :generic-function)
98           (print-description-to-string (symbol-function symbol)))
99          (:class
100           (print-description-to-string (find-class symbol))))))
101    
102  ;;;; Debugger  ;;;; Debugger
103    
104  (defvar *sldb-topframe*)  (defvar *sldb-topframe*)
105  (defvar *sldb-source*)  (defvar *sldb-source*)
106  (defvar *sldb-restarts*)  (defvar *sldb-restarts*)
107    
108  (defmethod call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
109    (let ((*sldb-topframe* (excl::int-newest-frame))    (let ((*sldb-topframe* (excl::int-newest-frame))
110          (*debugger-hook* nil)          (*debugger-hook* nil)
111          (excl::*break-hook* nil)          (excl::*break-hook* nil)
# Line 126  Line 135 
135            while f            while f
136            collect f)))            collect f)))
137    
138  (defmethod backtrace (start-frame-number end-frame-number)  (defimplementation backtrace (start-frame-number end-frame-number)
139    (flet ((format-frame (f i)    (flet ((format-frame (f i)
140             (print-with-frame-label             (print-with-frame-label
141              i (lambda (s) (debugger:output-frame s f :moderate)))))              i (lambda (s) (debugger:output-frame s f :moderate)))))
# Line 134  Line 143 
143            for f in (compute-backtrace start-frame-number end-frame-number)            for f in (compute-backtrace start-frame-number end-frame-number)
144            collect (list i (format-frame f i)))))            collect (list i (format-frame f i)))))
145    
146  (defmethod debugger-info-for-emacs (start end)  (defimplementation debugger-info-for-emacs (start end)
147    (list (debugger-condition-for-emacs)    (list (debugger-condition-for-emacs)
148          (format-restarts-for-emacs)          (format-restarts-for-emacs)
149          (backtrace start end)))          (backtrace start end)))
# Line 148  Line 157 
157  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
158    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
159    
160  (defmethod frame-locals (index)  (defimplementation frame-locals (index)
161    (let ((frame (nth-frame index)))    (let ((frame (nth-frame index)))
162      (loop for i from 0 below (debugger:frame-number-vars frame)      (loop for i from 0 below (debugger:frame-number-vars frame)
163            collect (list :name (to-string (debugger:frame-var-name frame i))            collect (list :name (to-string (debugger:frame-var-name frame i))
# Line 156  Line 165 
165                          :value-string                          :value-string
166                          (to-string (debugger:frame-var-value frame i))))))                          (to-string (debugger:frame-var-value frame i))))))
167    
168  (defmethod frame-catch-tags (index)  (defimplementation frame-catch-tags (index)
169    (declare (ignore index))    (declare (ignore index))
170    nil)    nil)
171    
172  (defmethod frame-source-location-for-emacs (index)  (defimplementation frame-source-location-for-emacs (index)
173    (list :error (format nil "Cannot find source for frame: ~A"    (list :error (format nil "Cannot find source for frame: ~A"
174                         (nth-frame index))))                         (nth-frame index))))
175    
176    (defimplementation eval-in-frame (form frame-number)
177      (debugger:eval-form-in-context
178       form
179       (debugger:environment-of-frame (nth-frame frame-number))))
180    
181  ;;;; Compiler hooks  ;;;; Compiler hooks
182    
183  (defvar *buffer-name* nil)  (defvar *buffer-name* nil)
# Line 192  Line 206 
206                                 (list :file *compile-filename*)                                 (list :file *compile-filename*)
207                                 (list :position 1))))))))                                 (list :position 1))))))))
208    
209  (defmethod compile-file-for-emacs (*compile-filename* load-p)  (defimplementation compile-file-for-emacs (*compile-filename* load-p)
210    (handler-bind ((warning #'handle-compiler-warning))    (handler-bind ((warning #'handle-compiler-warning))
211      (let ((*buffer-name* nil))      (let ((*buffer-name* nil))
212        (compile-file *compile-filename* :load-after-compile load-p))))        (compile-file *compile-filename* :load-after-compile load-p))))
213    
214  (defmethod compile-string-for-emacs (string &key buffer position)  (defimplementation compile-string-for-emacs (string &key buffer position)
215    (handler-bind ((warning #'handle-compiler-warning))    (handler-bind ((warning #'handle-compiler-warning))
216      (let ((*package* *buffer-package*)      (let ((*package* *buffer-package*)
217            (*buffer-name* buffer)            (*buffer-name* buffer)
# Line 234  Line 248 
248                  )))                  )))
249        locations)))        locations)))
250    
251  (defmethod find-function-locations (symbol-name)  (defimplementation find-function-locations (symbol-name)
252    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
253      (cond ((not foundp)      (cond ((not foundp)
254             (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))             (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
# Line 253  Line 267 
267  (defun lookup-xrefs (finder name)  (defun lookup-xrefs (finder name)
268    (xref-results-for-emacs (funcall finder (from-string name))))    (xref-results-for-emacs (funcall finder (from-string name))))
269    
270  (defslimefun who-calls (function-name)  (defimplementation who-calls (function-name)
271    (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))    (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
272                  function-name))                  function-name))
273    
274  (defslimefun who-references (variable)  (defimplementation who-references (variable)
275    (lookup-xrefs (lambda (x) (xref:get-relation :uses :wild x))    (lookup-xrefs (lambda (x) (xref:get-relation :uses :wild x))
276                  variable))                  variable))
277    
278  (defslimefun who-binds (variable)  (defimplementation who-binds (variable)
279    (lookup-xrefs (lambda (x) (xref:get-relation :binds :wild x))    (lookup-xrefs (lambda (x) (xref:get-relation :binds :wild x))
280                  variable))                  variable))
281    
282  (defslimefun who-sets (variable)  (defimplementation who-macroexpands (variable)
283      (lookup-xrefs (lambda (x) (xref:get-relation :macro-calls :wild x))
284                    variable))
285    
286    (defimplementation who-sets (variable)
287    (lookup-xrefs (lambda (x) (xref:get-relation :sets :wild x))    (lookup-xrefs (lambda (x) (xref:get-relation :sets :wild x))
288                  variable))                  variable))
289    
290  (defslimefun list-callers (name)  (defimplementation list-callers (name)
291    (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))    (lookup-xrefs (lambda (x) (xref:get-relation :calls :wild x))
292                  name))                  name))
293    
294  (defslimefun list-callees (name)  (defimplementation list-callees (name)
295    (lookup-xrefs (lambda (x) (xref:get-relation :calls x :wild))    (lookup-xrefs (lambda (x) (xref:get-relation :calls x :wild))
296                  name))                  name))
297    
# Line 286  Line 304 
304    
305  ;;;; Multiprocessing  ;;;; Multiprocessing
306    
307  (defmethod startup-multiprocessing ()  (defimplementation startup-multiprocessing ()
308    (mp:start-scheduler))    (mp:start-scheduler))
309    
310  (defmethod spawn (fn &key name)  (defimplementation spawn (fn &key name)
311    (mp:process-run-function name fn))    (mp:process-run-function name fn))
312    
313  ;; XXX: shurtcut  ;; XXX: shurtcut
314  (defmethod thread-id ()  (defimplementation thread-id ()
315    (mp:process-name mp:*current-process*))    (mp:process-name mp:*current-process*))
316    
317  (defmethod thread-name (thread-id)  (defimplementation thread-name (thread-id)
318    thread-id)    thread-id)
319    
320  (defmethod make-lock (&key name)  (defimplementation make-lock (&key name)
321    (mp:make-process-lock :name name))    (mp:make-process-lock :name name))
322    
323  (defmethod call-with-lock-held (lock function)  (defimplementation call-with-lock-held (lock function)
324    (mp:with-process-lock (lock) (funcall function)))    (mp:with-process-lock (lock) (funcall function)))

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

  ViewVC Help
Powered by ViewVC 1.1.5