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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5