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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.98 - (hide annotations)
Sun Nov 27 21:47:15 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.97: +2 -3 lines
* swank.lisp (create-server): Add a :backlog argument.
(setup-server): Pass it along.

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

  ViewVC Help
Powered by ViewVC 1.1.5