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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.99 - (hide annotations)
Sat Dec 3 12:03:26 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.98: +35 -0 lines
* swank-mrepl.lisp (package-prompt): Use <= instead of < to give
package-name priority over nicknames.
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     (multiple-value-bind (truename c) (ignore-errors (truename file))
334     (cond (truename
335     (make-location (list :file (namestring truename))
336     (if (consp lines)
337     (list* :line lines)
338 trittweiler 1.89 (list :function-name (string name)))
339     (when (consp type)
340     (list :snippet (format nil "~A" type)))))
341 heller 1.71 (t (list :error (princ-to-string c))))))
342     (t (list :error (format nil "No source information available for: ~S"
343     fspec)))))))
344 heller 1.25
345     (defimplementation find-definitions (name)
346 heller 1.71 (mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file)))
347 heller 1.1
348 heller 1.56 (defun trim-whitespace (string)
349     (string-trim #(#\newline #\space #\tab) string))
350 heller 1.1
351 heller 1.56 (defvar *sldb-backtrace*)
352 heller 1.30
353 heller 1.68 (eval-when (:compile-toplevel :load-toplevel :execute)
354     (when (string< "2.44" (lisp-implementation-version))
355     (pushnew :clisp-2.44+ *features*)))
356    
357     (defun sldb-backtrace ()
358     "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
359     (do ((frames '())
360     (last nil frame)
361     (frame (sys::the-frame)
362     #+clisp-2.44+ (sys::frame-up 1 frame 1)
363     #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
364     ((eq frame last) (nreverse frames))
365     (unless (boring-frame-p frame)
366     (push frame frames))))
367    
368 wjenkner 1.14 (defimplementation call-with-debugging-environment (debugger-loop-fn)
369 heller 1.57 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
370 mbaringer 1.63 ;;(sys::*driver* debugger-loop-fn)
371     ;;(sys::*fasoutput-stream* nil)
372     (*sldb-backtrace*
373     (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
374 heller 1.1 (funcall debugger-loop-fn)))
375    
376 mbaringer 1.63 (defun nth-frame (index)
377 heller 1.56 (nth index *sldb-backtrace*))
378    
379 heller 1.62 (defun boring-frame-p (frame)
380     (member (frame-type frame) '(stack-value bind-var bind-env)))
381    
382     (defun frame-to-string (frame)
383 mbaringer 1.63 (with-output-to-string (s)
384 heller 1.62 (sys::describe-frame s frame)))
385    
386 heller 1.68 ;; FIXME: they changed the layout in 2.44 so the frame-to-string &
387     ;; string-matching silliness no longer works.
388 heller 1.62 (defun frame-type (frame)
389     ;; FIXME: should bind *print-length* etc. to small values.
390     (frame-string-type (frame-to-string frame)))
391    
392     (defvar *frame-prefixes*
393     '(("frame binding variables" bind-var)
394     ("<1> #<compiled-function" compiled-fun)
395     ("<1> #<system-function" sys-fun)
396     ("<1> #<special-operator" special-op)
397     ("EVAL frame" eval)
398     ("APPLY frame" apply)
399     ("compiled tagbody frame" compiled-tagbody)
400     ("compiled block frame" compiled-block)
401     ("block frame" block)
402     ("nested block frame" block)
403     ("tagbody frame" tagbody)
404     ("nested tagbody frame" tagbody)
405     ("catch frame" catch)
406     ("handler frame" handler)
407     ("unwind-protect frame" unwind-protect)
408     ("driver frame" driver)
409     ("frame binding environments" bind-env)
410     ("CALLBACK frame" callback)
411     ("- " stack-value)
412     ("<1> " fun)
413     ("<2> " 2nd-frame)))
414    
415     (defun frame-string-type (string)
416     (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
417 mbaringer 1.63 *frame-prefixes*)))
418 heller 1.1
419 heller 1.25 (defimplementation compute-backtrace (start end)
420 heller 1.56 (let* ((bt *sldb-backtrace*)
421 mbaringer 1.63 (len (length bt)))
422 trittweiler 1.75 (loop for f in (subseq bt start (min (or end len) len))
423 heller 1.81 collect f)))
424 heller 1.1
425 heller 1.81 (defimplementation print-frame (frame stream)
426     (let* ((str (frame-to-string frame)))
427 mbaringer 1.63 (write-string (extract-frame-line str)
428     stream)))
429 heller 1.56
430 heller 1.62 (defun extract-frame-line (frame-string)
431     (let ((s frame-string))
432     (trim-whitespace
433     (case (frame-string-type s)
434     ((eval special-op)
435 mbaringer 1.63 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
436 heller 1.62 (apply
437 mbaringer 1.63 (string-match "APPLY frame for call \\(.*\\)" s 1))
438 heller 1.62 ((compiled-fun sys-fun fun)
439 mbaringer 1.63 (extract-function-name s))
440 heller 1.62 (t s)))))
441    
442     (defun extract-function-name (string)
443     (let ((1st (car (split-frame-string string))))
444     (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
445 mbaringer 1.63 1st
446     1)
447     (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
448     1st)))
449 heller 1.62
450     (defun split-frame-string (string)
451 mbaringer 1.63 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
452     (mapcar #'car *frame-prefixes*))))
453 heller 1.62 (loop for pos = 0 then (1+ (regexp:match-start match))
454 mbaringer 1.63 for match = (regexp:match rx string :start pos)
455     if match collect (subseq string pos (regexp:match-start match))
456     else collect (subseq string pos)
457     while match)))
458 heller 1.62
459     (defun string-match (pattern string n)
460     (let* ((match (nth-value n (regexp:match pattern string))))
461     (if match (regexp:match-string string match))))
462    
463 heller 1.56 (defimplementation format-sldb-condition (condition)
464     (trim-whitespace (princ-to-string condition)))
465 heller 1.1
466 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
467 heller 1.62 (sys::eval-at (nth-frame frame-number) form))
468 heller 1.1
469 mbaringer 1.63 (defimplementation frame-locals (frame-number)
470 heller 1.62 (let ((frame (nth-frame frame-number)))
471     (loop for i below (%frame-count-vars frame)
472 mbaringer 1.63 collect (list :name (%frame-var-name frame i)
473     :value (%frame-var-value frame i)
474     :id 0))))
475 heller 1.33
476 heller 1.62 (defimplementation frame-var-value (frame var)
477     (%frame-var-value (nth-frame frame) var))
478 heller 1.1
479 mbaringer 1.63 ;;; Interpreter-Variablen-Environment has the shape
480     ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
481 heller 1.1
482 heller 1.62 (defun %frame-count-vars (frame)
483     (cond ((sys::eval-frame-p frame)
484 mbaringer 1.63 (do ((venv (frame-venv frame) (next-venv venv))
485     (count 0 (+ count (/ (1- (length venv)) 2))))
486     ((not venv) count)))
487     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
488     (length (%parse-stack-values frame)))
489     (t 0)))
490 heller 1.62
491     (defun %frame-var-name (frame i)
492     (cond ((sys::eval-frame-p frame)
493 mbaringer 1.63 (nth-value 0 (venv-ref (frame-venv frame) i)))
494     (t (format nil "~D" i))))
495 heller 1.62
496     (defun %frame-var-value (frame i)
497     (cond ((sys::eval-frame-p frame)
498 mbaringer 1.63 (let ((name (venv-ref (frame-venv frame) i)))
499     (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
500     (if c
501     (format-sldb-condition c)
502     v))))
503     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
504     (let ((str (nth i (%parse-stack-values frame))))
505     (trim-whitespace (subseq str 2))))
506     (t (break "Not implemented"))))
507 heller 1.62
508     (defun frame-venv (frame)
509     (let ((env (sys::eval-at frame '(sys::the-environment))))
510     (svref env 0)))
511    
512     (defun next-venv (venv) (svref venv (1- (length venv))))
513    
514     (defun venv-ref (env i)
515     "Reference the Ith binding in ENV.
516     Return two values: NAME and VALUE"
517     (let ((idx (* i 2)))
518     (if (< idx (1- (length env)))
519 mbaringer 1.63 (values (svref env idx) (svref env (1+ idx)))
520     (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
521 heller 1.62
522     (defun %parse-stack-values (frame)
523 heller 1.68 (labels ((next (fp)
524     #+clisp-2.44+ (sys::frame-down 1 fp 1)
525     #-clisp-2.44+ (sys::frame-down-1 fp 1))
526 mbaringer 1.63 (parse (fp accu)
527     (let ((str (frame-to-string fp)))
528     (cond ((is-prefix-p "- " str)
529     (parse (next fp) (cons str accu)))
530     ((is-prefix-p "<1> " str)
531     ;;(when (eq (frame-type frame) 'compiled-fun)
532     ;; (pop accu))
533     (dolist (str (cdr (split-frame-string str)))
534     (when (is-prefix-p "- " str)
535     (push str accu)))
536     (nreverse accu))
537     (t (parse (next fp) accu))))))
538 heller 1.62 (parse (next frame) '())))
539    
540 heller 1.68 (setq *features* (remove :clisp-2.44+ *features*))
541    
542 heller 1.62 (defun is-prefix-p (pattern string)
543     (not (mismatch pattern string :end2 (min (length pattern)
544 mbaringer 1.63 (length string)))))
545 heller 1.1
546 wjenkner 1.14 (defimplementation return-from-frame (index form)
547 heller 1.62 (sys::return-from-eval-frame (nth-frame index) form))
548 wjenkner 1.14
549     (defimplementation restart-frame (index)
550 heller 1.62 (sys::redo-eval-frame (nth-frame index)))
551 wjenkner 1.14
552 heller 1.90 (defimplementation frame-source-location (index)
553 mbaringer 1.63 `(:error
554     ,(format nil "frame-source-location not implemented. (frame: ~A)"
555     (nth-frame index))))
556 heller 1.1
557 mbaringer 1.63 ;;;; Profiling
558 wjenkner 1.16
559     (defimplementation profile (fname)
560 mbaringer 1.63 (eval `(mon:monitor ,fname))) ;monitor is a macro
561 wjenkner 1.16
562     (defimplementation profiled-functions ()
563     mon:*monitored-functions*)
564    
565     (defimplementation unprofile (fname)
566 mbaringer 1.63 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
567 wjenkner 1.16
568     (defimplementation unprofile-all ()
569     (mon:unmonitor))
570    
571     (defimplementation profile-report ()
572     (mon:report-monitoring))
573    
574     (defimplementation profile-reset ()
575     (mon:reset-all-monitoring))
576    
577     (defimplementation profile-package (package callers-p methods)
578     (declare (ignore callers-p methods))
579     (mon:monitor-all package))
580 heller 1.1
581 mbaringer 1.63 ;;;; Handle compiler conditions (find out location of error etc.)
582 heller 1.1
583     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
584     "Pass ARGS to COMPILE-FILE, send the compiler notes to
585     *STANDARD-INPUT* and frob them in BODY."
586     `(let ((*error-output* (make-string-output-stream))
587 mbaringer 1.63 (*compile-verbose* t))
588 heller 1.1 (multiple-value-prog1
589 vsedach 1.6 (compile-file ,@args)
590 mbaringer 1.63 (handler-case
591 heller 1.1 (with-input-from-string
592 mbaringer 1.63 (*standard-input* (get-output-stream-string *error-output*))
593     ,@body)
594 vsedach 1.6 (sys::simple-end-of-file () nil)))))
595 heller 1.1
596 heller 1.25 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
597     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
598     (defvar *orig-c-error* (symbol-function 'system::c-error))
599     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
600    
601     (defmacro dynamic-flet (names-functions &body body)
602     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
603 heller 1.46 Execute BODY with NAME's function slot set to FUNCTION."
604 heller 1.25 `(ext:letf* ,(loop for (name function) in names-functions
605 mbaringer 1.63 collect `((symbol-function ',name) ,function))
606 heller 1.25 ,@body))
607 heller 1.45
608     (defvar *buffer-name* nil)
609     (defvar *buffer-offset*)
610    
611 heller 1.25 (defun compiler-note-location ()
612 heller 1.27 "Return the current compiler location."
613 heller 1.25 (let ((lineno1 sys::*compile-file-lineno1*)
614 mbaringer 1.63 (lineno2 sys::*compile-file-lineno2*)
615     (file sys::*compile-file-truename*))
616 heller 1.25 (cond ((and file lineno1 lineno2)
617 mbaringer 1.63 (make-location (list ':file (namestring file))
618     (list ':line lineno1)))
619     (*buffer-name*
620     (make-location (list ':buffer *buffer-name*)
621 heller 1.78 (list ':offset *buffer-offset* 0)))
622 mbaringer 1.63 (t
623     (list :error "No error location available")))))
624 heller 1.25
625     (defun signal-compiler-warning (cstring args severity orig-fn)
626     (signal (make-condition 'compiler-condition
627 mbaringer 1.63 :severity severity
628     :message (apply #'format nil cstring args)
629     :location (compiler-note-location)))
630 heller 1.25 (apply orig-fn cstring args))
631    
632     (defun c-warn (cstring &rest args)
633     (signal-compiler-warning cstring args :warning *orig-c-warn*))
634    
635     (defun c-style-warn (cstring &rest args)
636     (dynamic-flet ((sys::c-warn *orig-c-warn*))
637     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
638    
639     (defun c-error (cstring &rest args)
640     (signal-compiler-warning cstring args :error *orig-c-error*))
641    
642 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
643 heller 1.25 (handler-bind ((warning #'handle-notification-condition))
644     (dynamic-flet ((system::c-warn #'c-warn)
645 mbaringer 1.63 (system::c-style-warn #'c-style-warn)
646     (system::c-error #'c-error))
647 heller 1.25 (funcall function))))
648 heller 1.1
649     (defun handle-notification-condition (condition)
650     "Handle a condition caused by a compiler warning."
651 heller 1.25 (signal (make-condition 'compiler-condition
652 mbaringer 1.63 :original-condition condition
653     :severity :warning
654     :message (princ-to-string condition)
655     :location (compiler-note-location))))
656 heller 1.1
657 heller 1.88 (defimplementation swank-compile-file (input-file output-file
658 sboukarev 1.93 load-p external-format
659     &key policy)
660     (declare (ignore policy))
661 heller 1.60 (with-compilation-hooks ()
662     (with-compilation-unit ()
663 heller 1.79 (multiple-value-bind (fasl-file warningsp failurep)
664 heller 1.88 (compile-file input-file
665     :output-file output-file
666     :external-format external-format)
667 heller 1.79 (values fasl-file warningsp
668     (or failurep
669     (and load-p
670     (not (load fasl-file)))))))))
671 heller 1.1
672 heller 1.87 (defimplementation swank-compile-string (string &key buffer position filename
673 trittweiler 1.85 policy)
674 heller 1.87 (declare (ignore filename policy))
675 heller 1.1 (with-compilation-hooks ()
676 heller 1.25 (let ((*buffer-name* buffer)
677 mbaringer 1.63 (*buffer-offset* position))
678 heller 1.25 (funcall (compile nil (read-from-string
679 heller 1.80 (format nil "(~S () ~A)" 'lambda string))))
680     t)))
681 heller 1.1
682 mbaringer 1.63 ;;;; Portable XREF from the CMU AI repository.
683 heller 1.1
684 lgorrie 1.32 (setq pxref::*handle-package-forms* '(cl:in-package))
685 heller 1.1
686 heller 1.25 (defmacro defxref (name function)
687     `(defimplementation ,name (name)
688     (xref-results (,function name))))
689    
690 lgorrie 1.32 (defxref who-calls pxref:list-callers)
691     (defxref who-references pxref:list-readers)
692     (defxref who-binds pxref:list-setters)
693     (defxref who-sets pxref:list-setters)
694     (defxref list-callers pxref:list-callers)
695     (defxref list-callees pxref:list-callees)
696 heller 1.1
697 heller 1.28 (defun xref-results (symbols)
698 heller 1.1 (let ((xrefs '()))
699 heller 1.28 (dolist (symbol symbols)
700 heller 1.71 (push (fspec-location symbol symbol) xrefs))
701 heller 1.25 xrefs))
702 heller 1.1
703     (when (find-package :swank-loader)
704     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
705 mbaringer 1.63 (lambda ()
706     (let ((home (user-homedir-pathname)))
707     (and (ext:probe-directory home)
708     (probe-file (format nil "~A/.swank.lisp"
709     (namestring (truename home)))))))))
710 heller 1.1
711 mbaringer 1.63 ;;; Don't set *debugger-hook* to nil on break.
712     (ext:without-package-lock ()
713 heller 1.1 (defun break (&optional (format-string "Break") &rest args)
714     (if (not sys::*use-clcs*)
715     (progn
716 mbaringer 1.63 (terpri *error-output*)
717     (apply #'format *error-output*
718     (concatenate 'string "*** - " format-string)
719     args)
720     (funcall ext:*break-driver* t))
721 heller 1.1 (let ((condition
722 mbaringer 1.63 (make-condition 'simple-condition
723     :format-control format-string
724     :format-arguments args))
725     ;;(*debugger-hook* nil)
726     ;; Issue 91
727     )
728     (ext:with-restarts
729     ((continue
730     :report (lambda (stream)
731     (format stream (sys::text "Return from ~S loop")
732     'break))
733     ()))
734     (with-condition-restarts condition (list (find-restart 'continue))
735     (invoke-debugger condition)))))
736 heller 1.1 nil))
737 heller 1.40
738 mbaringer 1.63 ;;;; Inspecting
739 heller 1.23
740 heller 1.66 (defmethod emacs-inspect ((o t))
741 heller 1.23 (let* ((*print-array* nil) (*print-pretty* t)
742 mbaringer 1.63 (*print-circle* t) (*print-escape* t)
743     (*print-lines* custom:*inspect-print-lines*)
744     (*print-level* custom:*inspect-print-level*)
745     (*print-length* custom:*inspect-print-length*)
746     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
747     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
748     (*package* tmp-pack)
749     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
750 heller 1.23 (let ((inspection (sys::inspect-backend o)))
751 heller 1.67 (append (list
752     (format nil "~S~% ~A~{~%~A~}~%" o
753 mbaringer 1.63 (sys::insp-title inspection)
754 heller 1.67 (sys::insp-blurb inspection)))
755 mbaringer 1.35 (loop with count = (sys::insp-num-slots inspection)
756 mbaringer 1.63 for i below count
757     append (multiple-value-bind (value name)
758     (funcall (sys::insp-nth-slot inspection)
759     i)
760     `((:value ,name) " = " (:value ,value)
761     (:newline))))))))
762 heller 1.1
763 mbaringer 1.29 (defimplementation quit-lisp ()
764 heller 1.39 #+lisp=cl (ext:quit)
765     #-lisp=cl (lisp:quit))
766 mbaringer 1.29
767 trittweiler 1.91
768     (defimplementation preferred-communication-style ()
769     nil)
770    
771     ;;; FIXME
772     ;;;
773     ;;; Clisp 2.48 added experimental support for threads. Basically, you
774     ;;; can use :SPAWN now, BUT:
775     ;;;
776     ;;; - there are problems with GC, and threads stuffed into weak
777     ;;; hash-tables as is the case for *THREAD-PLIST-TABLE*.
778     ;;;
779     ;;; See test case at
780     ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429
781     ;;;
782     ;;; Even though said to be fixed, it's not:
783     ;;;
784     ;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443
785     ;;;
786     ;;; - The DYNAMIC-FLET above is an implementation technique that's
787     ;;; probably not sustainable in light of threads. This got to be
788     ;;; rewritten.
789     ;;;
790     ;;; TCR (2009-07-30)
791    
792     #+#.(cl:if (cl:find-package "MP") '(:and) '(:or))
793     (progn
794     (defimplementation spawn (fn &key name)
795     (mp:make-thread fn :name name))
796    
797     (defvar *thread-plist-table-lock*
798     (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK"))
799    
800     (defvar *thread-plist-table* (make-hash-table :weak :key)
801     "A hashtable mapping threads to a plist.")
802    
803     (defvar *thread-id-counter* 0)
804    
805     (defimplementation thread-id (thread)
806     (mp:with-mutex-lock (*thread-plist-table-lock*)
807     (or (getf (gethash thread *thread-plist-table*) 'thread-id)
808     (setf (getf (gethash thread *thread-plist-table*) 'thread-id)
809     (incf *thread-id-counter*)))))
810    
811     (defimplementation find-thread (id)
812     (find id (all-threads)
813     :key (lambda (thread)
814     (getf (gethash thread *thread-plist-table*) 'thread-id))))
815    
816     (defimplementation thread-name (thread)
817     ;; To guard against returning #<UNBOUND>.
818     (princ-to-string (mp:thread-name thread)))
819    
820     (defimplementation thread-status (thread)
821     (if (thread-alive-p thread)
822     "RUNNING"
823     "STOPPED"))
824    
825     (defimplementation make-lock (&key name)
826     (mp:make-mutex :name name :recursive-p t))
827    
828     (defimplementation call-with-lock-held (lock function)
829     (mp:with-mutex-lock (lock)
830     (funcall function)))
831    
832     (defimplementation current-thread ()
833     (mp:current-thread))
834    
835     (defimplementation all-threads ()
836     (mp:list-threads))
837    
838     (defimplementation interrupt-thread (thread fn)
839     (mp:thread-interrupt thread :function fn))
840    
841     (defimplementation kill-thread (thread)
842     (mp:thread-interrupt thread :function t))
843    
844     (defimplementation thread-alive-p (thread)
845     (mp:thread-active-p thread))
846    
847     (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK"))
848     (defvar *mailboxes* (list))
849    
850     (defstruct (mailbox (:conc-name mailbox.))
851     thread
852     (lock (make-lock :name "MAILBOX.LOCK"))
853     (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE"))
854     (queue '() :type list))
855    
856     (defun mailbox (thread)
857     "Return THREAD's mailbox."
858     (mp:with-mutex-lock (*mailboxes-lock*)
859     (or (find thread *mailboxes* :key #'mailbox.thread)
860     (let ((mb (make-mailbox :thread thread)))
861     (push mb *mailboxes*)
862     mb))))
863    
864     (defimplementation send (thread message)
865     (let* ((mbox (mailbox thread))
866     (lock (mailbox.lock mbox)))
867     (mp:with-mutex-lock (lock)
868     (setf (mailbox.queue mbox)
869     (nconc (mailbox.queue mbox) (list message)))
870     (mp:exemption-broadcast (mailbox.waitqueue mbox)))))
871    
872     (defimplementation receive-if (test &optional timeout)
873     (let* ((mbox (mailbox (current-thread)))
874     (lock (mailbox.lock mbox)))
875     (assert (or (not timeout) (eq timeout t)))
876     (loop
877     (check-slime-interrupts)
878     (mp:with-mutex-lock (lock)
879     (let* ((q (mailbox.queue mbox))
880     (tail (member-if test q)))
881     (when tail
882     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
883     (return (car tail))))
884     (when (eq timeout t) (return (values nil t)))
885     (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2))))))
886    
887 heller 1.70
888 mkoeppe 1.61 ;;;; Weak hashtables
889    
890     (defimplementation make-weak-key-hash-table (&rest args)
891     (apply #'make-hash-table :weak :key args))
892    
893     (defimplementation make-weak-value-hash-table (&rest args)
894     (apply #'make-hash-table :weak :value args))
895    
896 heller 1.74 (defimplementation save-image (filename &optional restart-function)
897     (let ((args `(,filename
898     ,@(if restart-function
899     `((:init-function ,restart-function))))))
900     (apply #'ext:saveinitmem args)))

  ViewVC Help
Powered by ViewVC 1.1.5