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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5