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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.104 - (hide annotations)
Sun Sep 29 07:39:48 2013 UTC (6 months, 2 weeks ago) by heller
Branch: MAIN
CVS Tags: HEAD
Changes since 1.103: +34 -29 lines
* swank-clisp.lisp (*frame-prefixes*): Update some of the patterns
for new layout.
(is-prefix-p): Use regexp matching.
(boring-frame-p): Also make compiled-tagbody compiled-block
boring.
(sldb-backtrace, %parse-stack-values): Remove code for versions
before 2.44.
1 heller 1.68 ;;;; -*- indent-tabs-mode: nil -*-
2 mbaringer 1.63
3 heller 1.1 ;;;; SWANK support for CLISP.
4    
5 vsedach 1.3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
6 heller 1.1
7 wjenkner 1.54 ;;;; This program is free software; you can redistribute it and/or
8 heller 1.1 ;;;; modify it under the terms of the GNU General Public License as
9 wjenkner 1.54 ;;;; published by the Free Software Foundation; either version 2 of
10     ;;;; the License, or (at your option) any later version.
11    
12     ;;;; This program is distributed in the hope that it will be useful,
13     ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14     ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15     ;;;; GNU General Public License for more details.
16    
17     ;;;; You should have received a copy of the GNU General Public
18     ;;;; License along with this program; if not, write to the Free
19     ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20     ;;;; MA 02111-1307, USA.
21 heller 1.1
22     ;;; This is work in progress, but it's already usable. Many things
23     ;;; are adapted from other swank-*.lisp, in particular from
24     ;;; swank-allegro (I don't use allegro at all, but it's the shortest
25     ;;; one and I found Helmut Eller's code there enlightening).
26    
27 wjenkner 1.54 ;;; This code will work better with recent versions of CLISP (say, the
28     ;;; last release or CVS HEAD) while it may not work at all with older
29     ;;; versions. It is reasonable to expect it to work on platforms with
30     ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
31     ;;; systems, but also on Win32. This backend uses the portable xref
32     ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
33     ;;; are conveniently included in SLIME.
34    
35 heller 1.20 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
36 heller 1.1
37 heller 1.25 (in-package :swank-backend)
38 heller 1.1
39 heller 1.104 (eval-when (:compile-toplevel)
40     (unless (string< "2.44" (lisp-implementation-version))
41     (error "Need at least CLISP version 2.44")))
42    
43 heller 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
44 heller 1.33 ;;(use-package "SOCKET")
45 heller 1.1 (use-package "GRAY"))
46    
47 heller 1.49 ;;;; if this lisp has the complete CLOS then we use it, otherwise we
48     ;;;; build up a "fake" swank-mop and then override the methods in the
49 mbaringer 1.36 ;;;; inspector.
50    
51     (eval-when (:compile-toplevel :load-toplevel :execute)
52     (defvar *have-mop*
53 mbaringer 1.37 (and (find-package :clos)
54     (eql :external
55 heller 1.44 (nth-value 1 (find-symbol (string ':standard-slot-definition)
56 mbaringer 1.63 :clos))))
57 heller 1.49 "True in those CLISP images which have a complete MOP implementation."))
58 mbaringer 1.37
59     #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
60     (progn
61 heller 1.44 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
62 mbaringer 1.63
63 mbaringer 1.37 (defun swank-mop:slot-definition-documentation (slot)
64     (clos::slot-definition-documentation slot)))
65 mbaringer 1.35
66 mbaringer 1.37 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
67 mbaringer 1.36 (defclass swank-mop:standard-slot-definition ()
68     ()
69 mbaringer 1.63 (:documentation
70 heller 1.44 "Dummy class created so that swank.lisp will compile and load."))
71 mbaringer 1.36
72 heller 1.49 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
73 mbaringer 1.63 ;; old name prior to 2005-03-01, clisp <= 2.33.2
74     (find-symbol "PROGRAM-ID" :system)
75     #+win32 ; integrated into the above since 2005-02-24
76     (and (find-package :win32) ; optional modules/win32
77     (find-symbol "GetCurrentProcessId" :win32)))))
78 heller 1.49 (defimplementation getpid () ; a required interface
79     (cond
80     (getpid (funcall getpid))
81     #+win32 ((ext:getenv "PID")) ; where does that come from?
82     (t -1))))
83 heller 1.1
84 heller 1.73 (defimplementation call-with-user-break-handler (handler function)
85     (handler-bind ((system::simple-interrupt-condition
86     (lambda (c)
87     (declare (ignore c))
88     (funcall handler)
89 heller 1.76 (when (find-restart 'socket-status)
90     (invoke-restart (find-restart 'socket-status)))
91 heller 1.73 (continue))))
92     (funcall function)))
93    
94 heller 1.21 (defimplementation lisp-implementation-type-name ()
95     "clisp")
96    
97 heller 1.28 (defimplementation set-default-directory (directory)
98     (setf (ext:default-directory) directory)
99     (namestring (setf *default-pathname-defaults* (ext:default-directory))))
100    
101 heller 1.83 (defimplementation filename-to-pathname (string)
102     (cond ((member :cygwin *features*)
103     (parse-cygwin-filename string))
104     (t (parse-namestring string))))
105    
106     (defun parse-cygwin-filename (string)
107     (multiple-value-bind (match _ drive absolute)
108     (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
109     (declare (ignore _))
110     (assert (and match (if drive absolute t)) ()
111     "Invalid filename syntax: ~a" string)
112     (let* ((sans-prefix (subseq string (regexp:match-end match)))
113     (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
114     (path (loop for name in path collect
115     (cond ((equal name "..") ':back)
116     (t name))))
117     (directoryp (or (equal string "")
118     (find (aref string (1- (length string))) "\\/"))))
119     (multiple-value-bind (file type)
120     (cond ((and (not directoryp) (last path))
121     (let* ((file (car (last path)))
122     (pos (position #\. file :from-end t)))
123     (cond ((and pos (> pos 0))
124     (values (subseq file 0 pos)
125     (subseq file (1+ pos))))
126     (t file)))))
127     (make-pathname :host nil
128     :device nil
129     :directory (cons
130     (if absolute :absolute :relative)
131     (let ((path (if directoryp
132     path
133     (butlast path))))
134     (if drive
135     (cons
136     (regexp:match-string string drive)
137     path)
138     path)))
139     :name file
140     :type type)))))
141    
142 heller 1.96 ;;;; UTF
143    
144     (defimplementation string-to-utf8 (string)
145     (let ((enc (load-time-value
146     (ext:make-encoding :charset "utf-8" :line-terminator :unix)
147     t)))
148     (ext:convert-string-to-bytes string enc)))
149    
150     (defimplementation utf8-to-string (octets)
151     (let ((enc (load-time-value
152     (ext:make-encoding :charset "utf-8" :line-terminator :unix)
153     t)))
154     (ext:convert-string-from-bytes octets enc)))
155    
156 mbaringer 1.63 ;;;; TCP Server
157 heller 1.1
158 heller 1.98 (defimplementation create-socket (host port &key backlog)
159     (socket:socket-server port :interface host :backlog (or backlog 5)))
160 lgorrie 1.7
161 wjenkner 1.14 (defimplementation local-port (socket)
162 heller 1.8 (socket:socket-server-port socket))
163 vsedach 1.5
164 wjenkner 1.14 (defimplementation close-socket (socket)
165 heller 1.8 (socket:socket-server-close socket))
166 mbaringer 1.63
167 heller 1.43 (defimplementation accept-connection (socket
168 mbaringer 1.63 &key external-format buffering timeout)
169 dcrosher 1.58 (declare (ignore buffering timeout))
170 heller 1.8 (socket:socket-accept socket
171 heller 1.97 :buffered buffering ;; XXX may not work if t
172     :element-type (if external-format
173     'character
174     '(unsigned-byte 8))
175     :external-format (or external-format :default)))
176 heller 1.60
177 heller 1.86 #-win32
178 heller 1.76 (defimplementation wait-for-input (streams &optional timeout)
179     (assert (member timeout '(nil t)))
180     (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
181     (loop
182 heller 1.77 (cond ((check-slime-interrupts) (return :interrupt))
183 heller 1.76 (timeout
184     (socket:socket-status streams 0 0)
185     (return (loop for (s _ . x) in streams
186     if x collect s)))
187     (t
188     (with-simple-restart (socket-status "Return from socket-status.")
189     (socket:socket-status streams 0 500000))
190     (let ((ready (loop for (s _ . x) in streams
191     if x collect s)))
192     (when ready (return ready))))))))
193    
194 heller 1.99 #+win32
195     (defimplementation wait-for-input (streams &optional timeout)
196     (assert (member timeout '(nil t)))
197     (loop
198     (cond ((check-slime-interrupts) (return :interrupt))
199     (t
200     (let ((ready (remove-if-not #'input-available-p streams)))
201     (when ready (return ready)))
202     (when timeout (return nil))
203     (sleep 0.1)))))
204    
205     #+win32
206     ;; Some facts to remember (for the next time we need to debug this):
207     ;; - interactive-sream-p returns t for socket-streams
208     ;; - listen returns nil for socket-streams
209     ;; - (type-of <socket-stream>) is 'stream
210     ;; - (type-of *terminal-io*) is 'two-way-stream
211     ;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8)
212     ;; - calling socket:socket-status on non sockets signals an error,
213     ;; but seems to mess up something internally.
214     ;; - calling read-char-no-hang on sockets does not signal an error,
215     ;; but seems to mess up something internally.
216     (defun input-available-p (stream)
217     (case (stream-element-type stream)
218     (character
219     (let ((c (read-char-no-hang stream nil nil)))
220     (cond ((not c)
221     nil)
222     (t
223     (unread-char c stream)
224     t))))
225     (t
226     (eq (socket:socket-status (cons stream :input) 0 0)
227     :input))))
228    
229 mbaringer 1.63 ;;;; Coding systems
230 heller 1.60
231     (defvar *external-format-to-coding-system*
232 mbaringer 1.63 '(((:charset "iso-8859-1" :line-terminator :unix)
233 heller 1.60 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
234 sboukarev 1.95 ((:charset "iso-8859-1")
235 heller 1.60 "latin-1" "iso-latin-1" "iso-8859-1")
236     ((:charset "utf-8") "utf-8")
237     ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
238     ((:charset "euc-jp") "euc-jp")
239     ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
240     ((:charset "us-ascii") "us-ascii")
241     ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
242    
243     (defimplementation find-external-format (coding-system)
244 mbaringer 1.63 (let ((args (car (rassoc-if (lambda (x)
245     (member coding-system x :test #'equal))
246     *external-format-to-coding-system*))))
247 heller 1.60 (and args (apply #'ext:make-encoding args))))
248    
249 vsedach 1.3
250 mbaringer 1.63 ;;;; Swank functions
251 heller 1.1
252 heller 1.25 (defimplementation arglist (fname)
253 heller 1.30 (block nil
254 heller 1.56 (or (ignore-errors
255 mbaringer 1.63 (let ((exp (function-lambda-expression fname)))
256     (and exp (return (second exp)))))
257     (ignore-errors
258     (return (ext:arglist fname)))
259     :not-available)))
260 heller 1.1
261 wjenkner 1.14 (defimplementation macroexpand-all (form)
262 heller 1.1 (ext:expand-form form))
263    
264 wjenkner 1.14 (defimplementation describe-symbol-for-emacs (symbol)
265 heller 1.1 "Return a plist describing SYMBOL.
266     Return NIL if the symbol is unbound."
267     (let ((result ()))
268 heller 1.47 (flet ((doc (kind)
269 mbaringer 1.63 (or (documentation symbol kind) :not-documented))
270     (maybe-push (property value)
271     (when value
272     (setf result (list* property value result)))))
273 heller 1.47 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
274 heller 1.1 (when (fboundp symbol)
275 mbaringer 1.63 (maybe-push
276     ;; Report WHEN etc. as macros, even though they may be
277     ;; implemented as special operators.
278     (if (macro-function symbol) :macro
279     (typecase (fdefinition symbol)
280     (generic-function :generic-function)
281     (function :function)
282     ;; (type-of 'progn) -> ext:special-operator
283     (t :special-operator)))
284     (doc 'function)))
285 heller 1.50 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
286 mbaringer 1.63 (get symbol 'system::setf-expander)); defsetf
287     (maybe-push :setf (doc 'setf)))
288 heller 1.50 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
289 mbaringer 1.63 (get symbol 'system::defstruct-description)
290     (get symbol 'system::deftype-expander))
291     (maybe-push :type (doc 'type))) ; even for 'structure
292 heller 1.50 (when (find-class symbol nil)
293 mbaringer 1.63 (maybe-push :class (doc 'type)))
294 heller 1.48 ;; Let this code work compiled in images without FFI
295     (let ((types (load-time-value
296 mbaringer 1.63 (and (find-package "FFI")
297     (symbol-value
298     (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
299     ;; Use ffi::*c-type-table* so as not to suffer the overhead of
300     ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
301     ;; which are not FFI type names.
302     (when (and types (nth-value 1 (gethash symbol types)))
303     ;; Maybe use (case (head (ffi:deparse-c-type)))
304     ;; to distinguish struct and union types?
305     (maybe-push :alien-type :not-documented)))
306 heller 1.1 result)))
307    
308 heller 1.25 (defimplementation describe-definition (symbol namespace)
309     (ecase namespace
310     (:variable (describe symbol))
311     (:macro (describe (macro-function symbol)))
312     (:function (describe (symbol-function symbol)))
313     (:class (describe (find-class symbol)))))
314    
315 sboukarev 1.103 (defimplementation type-specifier-p (symbol)
316     (or (ignore-errors
317     (subtypep nil symbol))
318     (not (eq (type-specifier-arglist symbol) :not-available))))
319    
320 heller 1.71 (defun fspec-pathname (spec)
321     (let ((path spec)
322     type
323 mbaringer 1.63 lines)
324 wjenkner 1.54 (when (consp path)
325 heller 1.71 (psetq type (car path)
326     path (cadr path)
327     lines (cddr path)))
328 wjenkner 1.54 (when (and path
329 mbaringer 1.63 (member (pathname-type path)
330     custom:*compiled-file-types* :test #'equal))
331 wjenkner 1.54 (setq path
332 mbaringer 1.63 (loop for suffix in custom:*source-file-types*
333     thereis (probe-file (make-pathname :defaults path
334     :type suffix)))))
335 heller 1.71 (values path type lines)))
336 heller 1.1
337 heller 1.71 (defun fspec-location (name fspec)
338     (multiple-value-bind (file type lines)
339 wjenkner 1.54 (fspec-pathname fspec)
340 heller 1.71 (list (if type (list name type) name)
341     (cond (file
342 heller 1.101 (multiple-value-bind (truename c)
343     (ignore-errors (truename file))
344 heller 1.71 (cond (truename
345 heller 1.101 (make-location
346     (list :file (namestring truename))
347     (if (consp lines)
348     (list* :line lines)
349     (list :function-name (string name)))
350     (when (consp type)
351     (list :snippet (format nil "~A" type)))))
352 heller 1.71 (t (list :error (princ-to-string c))))))
353 heller 1.101 (t (list :error
354     (format nil "No source information available for: ~S"
355     fspec)))))))
356 heller 1.25
357     (defimplementation find-definitions (name)
358 heller 1.101 (mapcar #'(lambda (e) (fspec-location name e))
359     (documentation name 'sys::file)))
360 heller 1.1
361 heller 1.56 (defun trim-whitespace (string)
362     (string-trim #(#\newline #\space #\tab) string))
363 heller 1.1
364 heller 1.56 (defvar *sldb-backtrace*)
365 heller 1.30
366 heller 1.68 (defun sldb-backtrace ()
367     "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
368 heller 1.104 (let* ((modes '((:all-stack-elements 1)
369     (:all-frames 2)
370     (:only-lexical-frames 3)
371     (:only-eval-and-apply-frames 4)
372     (:only-apply-frames 5)))
373     (mode (cadr (assoc :all-stack-elements modes))))
374     (do ((frames '())
375     (last nil frame)
376     (frame (sys::the-frame)
377     (sys::frame-up 1 frame mode)))
378     ((eq frame last) (nreverse frames))
379     (unless (boring-frame-p frame)
380     (push frame frames)))))
381 heller 1.68
382 wjenkner 1.14 (defimplementation call-with-debugging-environment (debugger-loop-fn)
383 heller 1.57 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
384 mbaringer 1.63 ;;(sys::*driver* debugger-loop-fn)
385     ;;(sys::*fasoutput-stream* nil)
386     (*sldb-backtrace*
387 heller 1.104 (let* ((f (sys::the-frame))
388     (bt (sldb-backtrace))
389     (rest (member f bt)))
390     (if rest (nthcdr 8 rest) bt))))
391 heller 1.1 (funcall debugger-loop-fn)))
392    
393 mbaringer 1.63 (defun nth-frame (index)
394 heller 1.56 (nth index *sldb-backtrace*))
395    
396 heller 1.62 (defun boring-frame-p (frame)
397 heller 1.104 (member (frame-type frame) '(stack-value bind-var bind-env
398     compiled-tagbody compiled-block)))
399 heller 1.62
400     (defun frame-to-string (frame)
401 mbaringer 1.63 (with-output-to-string (s)
402 heller 1.62 (sys::describe-frame s frame)))
403    
404     (defun frame-type (frame)
405     ;; FIXME: should bind *print-length* etc. to small values.
406     (frame-string-type (frame-to-string frame)))
407    
408 heller 1.104 ;; FIXME: they changed the layout in 2.44 and not all patterns have
409     ;; been updated.
410 heller 1.62 (defvar *frame-prefixes*
411 heller 1.104 '(("\\[[0-9]\\+\\] frame binding variables" bind-var)
412 heller 1.62 ("<1> #<compiled-function" compiled-fun)
413     ("<1> #<system-function" sys-fun)
414     ("<1> #<special-operator" special-op)
415     ("EVAL frame" eval)
416     ("APPLY frame" apply)
417 heller 1.104 ("\\[[0-9]\\+\\] compiled tagbody frame" compiled-tagbody)
418     ("\\[[0-9]\\+\\] compiled block frame" compiled-block)
419 heller 1.62 ("block frame" block)
420     ("nested block frame" block)
421     ("tagbody frame" tagbody)
422     ("nested tagbody frame" tagbody)
423     ("catch frame" catch)
424     ("handler frame" handler)
425     ("unwind-protect frame" unwind-protect)
426     ("driver frame" driver)
427 heller 1.104 ("\\[[0-9]\\+\\] frame binding environments" bind-env)
428 heller 1.62 ("CALLBACK frame" callback)
429     ("- " stack-value)
430     ("<1> " fun)
431 heller 1.104 ("<2> " 2nd-frame)
432     ))
433 heller 1.62
434     (defun frame-string-type (string)
435     (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
436 mbaringer 1.63 *frame-prefixes*)))
437 heller 1.1
438 heller 1.25 (defimplementation compute-backtrace (start end)
439 heller 1.56 (let* ((bt *sldb-backtrace*)
440 mbaringer 1.63 (len (length bt)))
441 trittweiler 1.75 (loop for f in (subseq bt start (min (or end len) len))
442 heller 1.81 collect f)))
443 heller 1.1
444 heller 1.81 (defimplementation print-frame (frame stream)
445     (let* ((str (frame-to-string frame)))
446 mbaringer 1.63 (write-string (extract-frame-line str)
447     stream)))
448 heller 1.56
449 heller 1.62 (defun extract-frame-line (frame-string)
450     (let ((s frame-string))
451     (trim-whitespace
452     (case (frame-string-type s)
453     ((eval special-op)
454 mbaringer 1.63 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
455 heller 1.62 (apply
456 mbaringer 1.63 (string-match "APPLY frame for call \\(.*\\)" s 1))
457 heller 1.62 ((compiled-fun sys-fun fun)
458 mbaringer 1.63 (extract-function-name s))
459 heller 1.62 (t s)))))
460    
461     (defun extract-function-name (string)
462     (let ((1st (car (split-frame-string string))))
463     (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
464 mbaringer 1.63 1st
465     1)
466     (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
467     1st)))
468 heller 1.62
469     (defun split-frame-string (string)
470 mbaringer 1.63 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
471     (mapcar #'car *frame-prefixes*))))
472 heller 1.62 (loop for pos = 0 then (1+ (regexp:match-start match))
473 mbaringer 1.63 for match = (regexp:match rx string :start pos)
474     if match collect (subseq string pos (regexp:match-start match))
475     else collect (subseq string pos)
476     while match)))
477 heller 1.62
478     (defun string-match (pattern string n)
479     (let* ((match (nth-value n (regexp:match pattern string))))
480     (if match (regexp:match-string string match))))
481    
482 heller 1.56 (defimplementation format-sldb-condition (condition)
483     (trim-whitespace (princ-to-string condition)))
484 heller 1.1
485 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
486 heller 1.62 (sys::eval-at (nth-frame frame-number) form))
487 heller 1.1
488 mbaringer 1.63 (defimplementation frame-locals (frame-number)
489 heller 1.62 (let ((frame (nth-frame frame-number)))
490     (loop for i below (%frame-count-vars frame)
491 mbaringer 1.63 collect (list :name (%frame-var-name frame i)
492     :value (%frame-var-value frame i)
493     :id 0))))
494 heller 1.33
495 heller 1.62 (defimplementation frame-var-value (frame var)
496     (%frame-var-value (nth-frame frame) var))
497 heller 1.1
498 mbaringer 1.63 ;;; Interpreter-Variablen-Environment has the shape
499     ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
500 heller 1.1
501 heller 1.62 (defun %frame-count-vars (frame)
502     (cond ((sys::eval-frame-p frame)
503 mbaringer 1.63 (do ((venv (frame-venv frame) (next-venv venv))
504     (count 0 (+ count (/ (1- (length venv)) 2))))
505     ((not venv) count)))
506     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
507     (length (%parse-stack-values frame)))
508     (t 0)))
509 heller 1.62
510     (defun %frame-var-name (frame i)
511     (cond ((sys::eval-frame-p frame)
512 mbaringer 1.63 (nth-value 0 (venv-ref (frame-venv frame) i)))
513     (t (format nil "~D" i))))
514 heller 1.62
515     (defun %frame-var-value (frame i)
516     (cond ((sys::eval-frame-p frame)
517 mbaringer 1.63 (let ((name (venv-ref (frame-venv frame) i)))
518     (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
519     (if c
520     (format-sldb-condition c)
521     v))))
522     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
523     (let ((str (nth i (%parse-stack-values frame))))
524     (trim-whitespace (subseq str 2))))
525     (t (break "Not implemented"))))
526 heller 1.62
527     (defun frame-venv (frame)
528     (let ((env (sys::eval-at frame '(sys::the-environment))))
529     (svref env 0)))
530    
531     (defun next-venv (venv) (svref venv (1- (length venv))))
532    
533     (defun venv-ref (env i)
534     "Reference the Ith binding in ENV.
535     Return two values: NAME and VALUE"
536     (let ((idx (* i 2)))
537     (if (< idx (1- (length env)))
538 mbaringer 1.63 (values (svref env idx) (svref env (1+ idx)))
539     (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
540 heller 1.62
541     (defun %parse-stack-values (frame)
542 heller 1.104 (labels ((next (fp) (sys::frame-down 1 fp 1))
543 mbaringer 1.63 (parse (fp accu)
544     (let ((str (frame-to-string fp)))
545     (cond ((is-prefix-p "- " str)
546     (parse (next fp) (cons str accu)))
547     ((is-prefix-p "<1> " str)
548     ;;(when (eq (frame-type frame) 'compiled-fun)
549     ;; (pop accu))
550     (dolist (str (cdr (split-frame-string str)))
551     (when (is-prefix-p "- " str)
552     (push str accu)))
553     (nreverse accu))
554     (t (parse (next fp) accu))))))
555 heller 1.62 (parse (next frame) '())))
556    
557 heller 1.104 (defun is-prefix-p (regexp string)
558     (if (regexp:match (concatenate 'string "^" regexp) string) t))
559 heller 1.1
560 wjenkner 1.14 (defimplementation return-from-frame (index form)
561 heller 1.62 (sys::return-from-eval-frame (nth-frame index) form))
562 wjenkner 1.14
563     (defimplementation restart-frame (index)
564 heller 1.62 (sys::redo-eval-frame (nth-frame index)))
565 wjenkner 1.14
566 heller 1.90 (defimplementation frame-source-location (index)
567 mbaringer 1.63 `(:error
568     ,(format nil "frame-source-location not implemented. (frame: ~A)"
569     (nth-frame index))))
570 heller 1.1
571 mbaringer 1.63 ;;;; Profiling
572 wjenkner 1.16
573     (defimplementation profile (fname)
574 mbaringer 1.63 (eval `(mon:monitor ,fname))) ;monitor is a macro
575 wjenkner 1.16
576     (defimplementation profiled-functions ()
577     mon:*monitored-functions*)
578    
579     (defimplementation unprofile (fname)
580 mbaringer 1.63 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
581 wjenkner 1.16
582     (defimplementation unprofile-all ()
583     (mon:unmonitor))
584    
585     (defimplementation profile-report ()
586     (mon:report-monitoring))
587    
588     (defimplementation profile-reset ()
589     (mon:reset-all-monitoring))
590    
591     (defimplementation profile-package (package callers-p methods)
592     (declare (ignore callers-p methods))
593     (mon:monitor-all package))
594 heller 1.1
595 mbaringer 1.63 ;;;; Handle compiler conditions (find out location of error etc.)
596 heller 1.1
597     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
598     "Pass ARGS to COMPILE-FILE, send the compiler notes to
599     *STANDARD-INPUT* and frob them in BODY."
600     `(let ((*error-output* (make-string-output-stream))
601 mbaringer 1.63 (*compile-verbose* t))
602 heller 1.1 (multiple-value-prog1
603 vsedach 1.6 (compile-file ,@args)
604 mbaringer 1.63 (handler-case
605 heller 1.1 (with-input-from-string
606 mbaringer 1.63 (*standard-input* (get-output-stream-string *error-output*))
607     ,@body)
608 vsedach 1.6 (sys::simple-end-of-file () nil)))))
609 heller 1.1
610 heller 1.25 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
611     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
612     (defvar *orig-c-error* (symbol-function 'system::c-error))
613     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
614    
615     (defmacro dynamic-flet (names-functions &body body)
616     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
617 heller 1.46 Execute BODY with NAME's function slot set to FUNCTION."
618 heller 1.25 `(ext:letf* ,(loop for (name function) in names-functions
619 mbaringer 1.63 collect `((symbol-function ',name) ,function))
620 heller 1.25 ,@body))
621 heller 1.45
622     (defvar *buffer-name* nil)
623     (defvar *buffer-offset*)
624    
625 heller 1.25 (defun compiler-note-location ()
626 heller 1.27 "Return the current compiler location."
627 heller 1.25 (let ((lineno1 sys::*compile-file-lineno1*)
628 mbaringer 1.63 (lineno2 sys::*compile-file-lineno2*)
629     (file sys::*compile-file-truename*))
630 heller 1.25 (cond ((and file lineno1 lineno2)
631 mbaringer 1.63 (make-location (list ':file (namestring file))
632     (list ':line lineno1)))
633     (*buffer-name*
634     (make-location (list ':buffer *buffer-name*)
635 heller 1.78 (list ':offset *buffer-offset* 0)))
636 mbaringer 1.63 (t
637     (list :error "No error location available")))))
638 heller 1.25
639     (defun signal-compiler-warning (cstring args severity orig-fn)
640 sboukarev 1.102 (signal 'compiler-condition
641     :severity severity
642     :message (apply #'format nil cstring args)
643     :location (compiler-note-location))
644 heller 1.25 (apply orig-fn cstring args))
645    
646     (defun c-warn (cstring &rest args)
647     (signal-compiler-warning cstring args :warning *orig-c-warn*))
648    
649     (defun c-style-warn (cstring &rest args)
650     (dynamic-flet ((sys::c-warn *orig-c-warn*))
651     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
652    
653 sboukarev 1.100 (defun c-error (&rest args)
654 sboukarev 1.102 (signal 'compiler-condition
655     :severity :error
656     :message (apply #'format nil
657     (if (= (length args) 3)
658     (cdr args)
659     args))
660     :location (compiler-note-location))
661 sboukarev 1.100 (apply *orig-c-error* args))
662 heller 1.25
663 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
664 heller 1.25 (handler-bind ((warning #'handle-notification-condition))
665     (dynamic-flet ((system::c-warn #'c-warn)
666 mbaringer 1.63 (system::c-style-warn #'c-style-warn)
667     (system::c-error #'c-error))
668 heller 1.25 (funcall function))))
669 heller 1.1
670     (defun handle-notification-condition (condition)
671     "Handle a condition caused by a compiler warning."
672 sboukarev 1.102 (signal 'compiler-condition
673     :original-condition condition
674     :severity :warning
675     :message (princ-to-string condition)
676     :location (compiler-note-location)))
677 heller 1.1
678 heller 1.88 (defimplementation swank-compile-file (input-file output-file
679 sboukarev 1.93 load-p external-format
680     &key policy)
681     (declare (ignore policy))
682 heller 1.60 (with-compilation-hooks ()
683     (with-compilation-unit ()
684 heller 1.79 (multiple-value-bind (fasl-file warningsp failurep)
685 heller 1.88 (compile-file input-file
686     :output-file output-file
687     :external-format external-format)
688 heller 1.79 (values fasl-file warningsp
689     (or failurep
690     (and load-p
691     (not (load fasl-file)))))))))
692 heller 1.1
693 heller 1.87 (defimplementation swank-compile-string (string &key buffer position filename
694 trittweiler 1.85 policy)
695 heller 1.87 (declare (ignore filename policy))
696 heller 1.1 (with-compilation-hooks ()
697 heller 1.25 (let ((*buffer-name* buffer)
698 mbaringer 1.63 (*buffer-offset* position))
699 heller 1.25 (funcall (compile nil (read-from-string
700 heller 1.80 (format nil "(~S () ~A)" 'lambda string))))
701     t)))
702 heller 1.1
703 mbaringer 1.63 ;;;; Portable XREF from the CMU AI repository.
704 heller 1.1
705 lgorrie 1.32 (setq pxref::*handle-package-forms* '(cl:in-package))
706 heller 1.1
707 heller 1.25 (defmacro defxref (name function)
708     `(defimplementation ,name (name)
709     (xref-results (,function name))))
710    
711 lgorrie 1.32 (defxref who-calls pxref:list-callers)
712     (defxref who-references pxref:list-readers)
713     (defxref who-binds pxref:list-setters)
714     (defxref who-sets pxref:list-setters)
715     (defxref list-callers pxref:list-callers)
716     (defxref list-callees pxref:list-callees)
717 heller 1.1
718 heller 1.28 (defun xref-results (symbols)
719 heller 1.1 (let ((xrefs '()))
720 heller 1.28 (dolist (symbol symbols)
721 heller 1.71 (push (fspec-location symbol symbol) xrefs))
722 heller 1.25 xrefs))
723 heller 1.1
724     (when (find-package :swank-loader)
725     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
726 mbaringer 1.63 (lambda ()
727     (let ((home (user-homedir-pathname)))
728     (and (ext:probe-directory home)
729     (probe-file (format nil "~A/.swank.lisp"
730     (namestring (truename home)))))))))
731 heller 1.1
732 mbaringer 1.63 ;;; Don't set *debugger-hook* to nil on break.
733     (ext:without-package-lock ()
734 heller 1.1 (defun break (&optional (format-string "Break") &rest args)
735     (if (not sys::*use-clcs*)
736     (progn
737 mbaringer 1.63 (terpri *error-output*)
738     (apply #'format *error-output*
739     (concatenate 'string "*** - " format-string)
740     args)
741     (funcall ext:*break-driver* t))
742 heller 1.1 (let ((condition
743 mbaringer 1.63 (make-condition 'simple-condition
744     :format-control format-string
745     :format-arguments args))
746     ;;(*debugger-hook* nil)
747     ;; Issue 91
748     )
749     (ext:with-restarts
750     ((continue
751     :report (lambda (stream)
752     (format stream (sys::text "Return from ~S loop")
753     'break))
754     ()))
755     (with-condition-restarts condition (list (find-restart 'continue))
756     (invoke-debugger condition)))))
757 heller 1.1 nil))
758 heller 1.40
759 mbaringer 1.63 ;;;; Inspecting
760 heller 1.23
761 heller 1.66 (defmethod emacs-inspect ((o t))
762 heller 1.23 (let* ((*print-array* nil) (*print-pretty* t)
763 mbaringer 1.63 (*print-circle* t) (*print-escape* t)
764     (*print-lines* custom:*inspect-print-lines*)
765     (*print-level* custom:*inspect-print-level*)
766     (*print-length* custom:*inspect-print-length*)
767     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
768     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
769     (*package* tmp-pack)
770     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
771 heller 1.23 (let ((inspection (sys::inspect-backend o)))
772 heller 1.67 (append (list
773     (format nil "~S~% ~A~{~%~A~}~%" o
774 mbaringer 1.63 (sys::insp-title inspection)
775 heller 1.67 (sys::insp-blurb inspection)))
776 mbaringer 1.35 (loop with count = (sys::insp-num-slots inspection)
777 mbaringer 1.63 for i below count
778     append (multiple-value-bind (value name)
779     (funcall (sys::insp-nth-slot inspection)
780     i)
781     `((:value ,name) " = " (:value ,value)
782     (:newline))))))))
783 heller 1.1
784 mbaringer 1.29 (defimplementation quit-lisp ()
785 heller 1.39 #+lisp=cl (ext:quit)
786     #-lisp=cl (lisp:quit))
787 mbaringer 1.29
788 trittweiler 1.91
789     (defimplementation preferred-communication-style ()
790     nil)
791    
792     ;;; FIXME
793     ;;;
794     ;;; Clisp 2.48 added experimental support for threads. Basically, you
795     ;;; can use :SPAWN now, BUT:
796     ;;;
797     ;;; - there are problems with GC, and threads stuffed into weak
798     ;;; hash-tables as is the case for *THREAD-PLIST-TABLE*.
799     ;;;
800     ;;; See test case at
801     ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429
802     ;;;
803     ;;; Even though said to be fixed, it's not:
804     ;;;
805     ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
806     ;;;
807     ;;; - The DYNAMIC-FLET above is an implementation technique that's
808     ;;; probably not sustainable in light of threads. This got to be
809     ;;; rewritten.
810     ;;;
811     ;;; TCR (2009-07-30)
812    
813     #+#.(cl:if (cl:find-package "MP") '(:and) '(:or))
814     (progn
815     (defimplementation spawn (fn &key name)
816     (mp:make-thread fn :name name))
817    
818     (defvar *thread-plist-table-lock*
819     (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
820    
821     (defvar *thread-plist-table* (make-hash-table :weak :key)
822     "A hashtable mapping threads to a plist.")
823    
824     (defvar *thread-id-counter* 0)
825    
826     (defimplementation thread-id (thread)
827     (mp:with-mutex-lock (*thread-plist-table-lock*)
828     (or (getf (gethash thread *thread-plist-table*) 'thread-id)
829     (setf (getf (gethash thread *thread-plist-table*) 'thread-id)
830     (incf *thread-id-counter*)))))
831    
832     (defimplementation find-thread (id)
833     (find id (all-threads)
834     :key (lambda (thread)
835     (getf (gethash thread *thread-plist-table*) 'thread-id))))
836    
837     (defimplementation thread-name (thread)
838     ;; To guard against returning #<UNBOUND>.
839     (princ-to-string (mp:thread-name thread)))
840    
841     (defimplementation thread-status (thread)
842     (if (thread-alive-p thread)
843     "RUNNING"
844     "STOPPED"))
845    
846     (defimplementation make-lock (&key name)
847     (mp:make-mutex :name name :recursive-p t))
848    
849     (defimplementation call-with-lock-held (lock function)
850     (mp:with-mutex-lock (lock)
851     (funcall function)))
852    
853     (defimplementation current-thread ()
854     (mp:current-thread))
855    
856     (defimplementation all-threads ()
857     (mp:list-threads))
858    
859     (defimplementation interrupt-thread (thread fn)
860     (mp:thread-interrupt thread :function fn))
861    
862     (defimplementation kill-thread (thread)
863     (mp:thread-interrupt thread :function t))
864    
865     (defimplementation thread-alive-p (thread)
866     (mp:thread-active-p thread))
867    
868     (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
869     (defvar *mailboxes* (list))
870    
871     (defstruct (mailbox (:conc-name mailbox.))
872     thread
873     (lock (make-lock :name "MAILBOX.LOCK"))
874     (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
875     (queue '() :type list))
876    
877     (defun mailbox (thread)
878     "Return THREAD's mailbox."
879     (mp:with-mutex-lock (*mailboxes-lock*)
880     (or (find thread *mailboxes* :key #'mailbox.thread)
881     (let ((mb (make-mailbox :thread thread)))
882     (push mb *mailboxes*)
883     mb))))
884    
885     (defimplementation send (thread message)
886     (let* ((mbox (mailbox thread))
887     (lock (mailbox.lock mbox)))
888     (mp:with-mutex-lock (lock)
889     (setf (mailbox.queue mbox)
890     (nconc (mailbox.queue mbox) (list message)))
891     (mp:exemption-broadcast (mailbox.waitqueue mbox)))))
892    
893     (defimplementation receive-if (test &optional timeout)
894     (let* ((mbox (mailbox (current-thread)))
895     (lock (mailbox.lock mbox)))
896     (assert (or (not timeout) (eq timeout t)))
897     (loop
898     (check-slime-interrupts)
899     (mp:with-mutex-lock (lock)
900     (let* ((q (mailbox.queue mbox))
901     (tail (member-if test q)))
902     (when tail
903     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
904     (return (car tail))))
905     (when (eq timeout t) (return (values nil t)))
906     (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
907    
908 heller 1.70
909 mkoeppe 1.61 ;;;; Weak hashtables
910    
911     (defimplementation make-weak-key-hash-table (&rest args)
912     (apply #'make-hash-table :weak :key args))
913    
914     (defimplementation make-weak-value-hash-table (&rest args)
915     (apply #'make-hash-table :weak :value args))
916    
917 heller 1.74 (defimplementation save-image (filename &optional restart-function)
918     (let ((args `(,filename
919     ,@(if restart-function
920     `((:init-function ,restart-function))))))
921     (apply #'ext:saveinitmem args)))

  ViewVC Help
Powered by ViewVC 1.1.5