1(define-module (ice-9 gds-client)
2  #:use-module (oop goops)
3  #:use-module (oop goops describe)
4  #:use-module (ice-9 debugging trace)
5  #:use-module (ice-9 debugging traps)
6  #:use-module (ice-9 debugging trc)
7  #:use-module (ice-9 debugging steps)
8  #:use-module (ice-9 pretty-print)
9  #:use-module (ice-9 regex)
10  #:use-module (ice-9 session)
11  #:use-module (ice-9 string-fun)
12  #:export (gds-debug-trap
13	    run-utility
14	    gds-accept-input))
15
16(cond ((string>=? (version) "1.7")
17       (use-modules (ice-9 debugger utils)))
18      (else
19       (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
20       (module-export! the-ice-9-debugger-module
21		       '(source-position
22			 write-frame-short/application
23			 write-frame-short/expression
24			 write-frame-args-long
25			 write-frame-long))))
26
27(use-modules (ice-9 debugger))
28
29(define gds-port #f)
30
31;; Return an integer that somehow identifies the current thread.
32(define (get-thread-id)
33  (let ((root (dynamic-root)))
34    (cond ((integer? root)
35	   root)
36	  ((pair? root)
37	   (object-address root))
38	  (else
39	   (error "Unexpected dynamic root:" root)))))
40
41;; gds-debug-read is a high-priority read.  The (debug-thread-id ID)
42;; form causes the frontend to dismiss any reads from threads whose id
43;; is not ID, until it receives the (thread-id ...) form with the same
44;; id as ID.  Dismissing the reads of any other threads (by sending a
45;; form that is otherwise ignored) causes those threads to release the
46;; read mutex, which allows the (gds-read) here to proceed.
47(define (gds-debug-read)
48  (write-form `(debug-thread-id ,(get-thread-id)))
49  (gds-read))
50
51(define (gds-debug-trap trap-context)
52  "Invoke the GDS debugger to explore the stack at the specified trap."
53  (connect-to-gds)
54  (start-stack 'debugger
55               (let* ((stack (tc:stack trap-context))
56		      (flags1 (let ((trap-type (tc:type trap-context)))
57				(case trap-type
58				  ((#:return #:error)
59				   (list trap-type
60					 (tc:return-value trap-context)))
61				  (else
62				   (list trap-type)))))
63		      (flags (if (tc:continuation trap-context)
64				 (cons #:continuable flags1)
65				 flags1))
66		      (fired-traps (tc:fired-traps trap-context))
67		      (special-index (and (= (length fired-traps) 1)
68					  (is-a? (car fired-traps) <exit-trap>)
69					  (eq? (tc:type trap-context) #:return)
70					  (- (tc:depth trap-context)
71					     (slot-ref (car fired-traps) 'depth)))))
72                 ;; Write current stack to the frontend.
73                 (write-form (list 'stack
74				   (if (and special-index (> special-index 0))
75				       special-index
76				       0)
77                                   (stack->emacs-readable stack)
78                                   (append (flags->emacs-readable flags)
79                                           (slot-ref trap-context
80                                                     'handler-return-syms))))
81		 ;; Now wait for instruction.
82                 (let loop ((protocol (gds-debug-read)))
83                   ;; Act on it.
84                   (case (car protocol)
85                     ((tweak)
86		      ;; Request to tweak the handler return value.
87		      (let ((tweaking (catch #t
88					     (lambda ()
89					       (list (with-input-from-string
90							 (cadr protocol)
91						       read)))
92					     (lambda ignored #f))))
93			(if tweaking
94			    (slot-set! trap-context
95				       'handler-return-value
96				       (cons 'instead (car tweaking)))))
97                      (loop (gds-debug-read)))
98                     ((continue)
99                      ;; Continue (by exiting the debugger).
100                      *unspecified*)
101                     ((evaluate)
102                      ;; Evaluate expression in specified frame.
103                      (eval-in-frame stack (cadr protocol) (caddr protocol))
104                      (loop (gds-debug-read)))
105                     ((info-frame)
106                      ;; Return frame info.
107                      (let ((frame (stack-ref stack (cadr protocol))))
108                        (write-form (list 'info-result
109                                          (with-output-to-string
110                                            (lambda ()
111                                              (write-frame-long frame))))))
112                      (loop (gds-debug-read)))
113                     ((info-args)
114                      ;; Return frame args.
115                      (let ((frame (stack-ref stack (cadr protocol))))
116                        (write-form (list 'info-result
117                                          (with-output-to-string
118                                            (lambda ()
119                                              (write-frame-args-long frame))))))
120                      (loop (gds-debug-read)))
121                     ((proc-source)
122                      ;; Show source of application procedure.
123                      (let* ((frame (stack-ref stack (cadr protocol)))
124                             (proc (frame-procedure frame))
125                             (source (and proc (procedure-source proc))))
126                        (write-form (list 'info-result
127                                          (if source
128                                              (sans-surrounding-whitespace
129                                               (with-output-to-string
130                                                 (lambda ()
131                                                   (pretty-print source))))
132                                              (if proc
133                                                  "This procedure is coded in C"
134                                                  "This frame has no procedure")))))
135                      (loop (gds-debug-read)))
136		     ((traps-here)
137		      ;; Show the traps that fired here.
138		      (write-form (list 'info-result
139					(with-output-to-string
140					  (lambda ()
141					    (for-each describe
142						 (tc:fired-traps trap-context))))))
143		      (loop (gds-debug-read)))
144                     ((step-into)
145                      ;; Set temporary breakpoint on next trap.
146                      (at-step gds-debug-trap
147                               1
148			       #f
149			       (if (memq #:return flags)
150				   #f
151				   (- (stack-length stack)
152				      (cadr protocol)))))
153                     ((step-over)
154                      ;; Set temporary breakpoint on exit from
155                      ;; specified frame.
156                      (at-exit (- (stack-length stack) (cadr protocol))
157                               gds-debug-trap))
158                     ((step-file)
159                      ;; Set temporary breakpoint on next trap in same
160                      ;; source file.
161                      (at-step gds-debug-trap
162                               1
163                               (frame-file-name (stack-ref stack
164                                                           (cadr protocol)))
165			       (if (memq #:return flags)
166				   #f
167				   (- (stack-length stack)
168				      (cadr protocol)))))
169                     (else
170                      (safely-handle-nondebug-protocol protocol)
171                      (loop (gds-debug-read))))))))
172
173(define (connect-to-gds . application-name)
174  (or gds-port
175      (begin
176        (set! gds-port
177	      (or (let ((s (socket PF_INET SOCK_STREAM 0))
178			(SOL_TCP 6)
179			(TCP_NODELAY 1))
180		    (setsockopt s SOL_TCP TCP_NODELAY 1)
181		    (catch #t
182			   (lambda ()
183			     (connect s AF_INET (inet-aton "127.0.0.1") 8333)
184			     s)
185			   (lambda _ #f)))
186		  (let ((s (socket PF_UNIX SOCK_STREAM 0)))
187		    (catch #t
188			   (lambda ()
189			     (connect s AF_UNIX "/tmp/.gds_socket")
190			     s)
191			   (lambda _ #f)))
192		  (error "Couldn't connect to GDS by TCP or Unix domain socket")))
193        (write-form (list 'name (getpid) (apply client-name application-name))))))
194
195(define (client-name . application-name)
196  (let loop ((args (append application-name (program-arguments))))
197    (if (null? args)
198	(format #f "PID ~A" (getpid))
199	(let ((arg (car args)))
200	  (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
201		 (loop (cdr args)))
202		((string-match "^-" arg)
203		 (loop (cdr args)))
204		(else
205		 (format #f "~A (PID ~A)" arg (getpid))))))))
206
207(if (not (defined? 'make-mutex))
208    (begin
209      (define (make-mutex) #f)
210      (define lock-mutex noop)
211      (define unlock-mutex noop)))
212
213(define write-mutex (make-mutex))
214
215(define (write-form form)
216  ;; Write any form FORM to GDS.
217  (lock-mutex write-mutex)
218  (write form gds-port)
219  (newline gds-port)
220  (force-output gds-port)
221  (unlock-mutex write-mutex))
222
223(define (stack->emacs-readable stack)
224  ;; Return Emacs-readable representation of STACK.
225  (map (lambda (index)
226	 (frame->emacs-readable (stack-ref stack index)))
227       (iota (min (stack-length stack)
228		  (cadr (memq 'depth (debug-options)))))))
229
230(define (frame->emacs-readable frame)
231  ;; Return Emacs-readable representation of FRAME.
232  (if (frame-procedure? frame)
233      (list 'application
234	    (with-output-to-string
235	     (lambda ()
236	       (display (if (frame-real? frame) "  " "t "))
237	       (write-frame-short/application frame)))
238	    (source->emacs-readable frame))
239      (list 'evaluation
240	    (with-output-to-string
241	     (lambda ()
242	       (display (if (frame-real? frame) "  " "t "))
243	       (write-frame-short/expression frame)))
244	    (source->emacs-readable frame))))
245
246(define (source->emacs-readable frame)
247  ;; Return Emacs-readable representation of the filename, line and
248  ;; column source properties of SOURCE.
249  (or (frame->source-position frame) 'nil))
250
251(define (flags->emacs-readable flags)
252  ;; Return Emacs-readable representation of trap FLAGS.
253  (let ((prev #f))
254    (map (lambda (flag)
255	   (let ((erf (if (and (keyword? flag)
256			       (not (eq? prev #:return)))
257			  (keyword->symbol flag)
258			  (format #f "~S" flag))))
259	     (set! prev flag)
260	     erf))
261	 flags)))
262
263(define (eval-in-frame stack index expr)
264  (write-form
265   (list 'eval-result
266         (format #f "~S"
267                 (catch #t
268                        (lambda ()
269                          (local-eval (with-input-from-string expr read)
270                                      (memoized-environment
271                                       (frame-source (stack-ref stack
272                                                                index)))))
273                        (lambda args
274                          (cons 'ERROR args)))))))
275
276(set! (behaviour-ordering gds-debug-trap) 100)
277
278;;; Code below here adds support for interaction between the GDS
279;;; client program and the Emacs frontend even when not stopped in the
280;;; debugger.
281
282;; A mutex to control attempts by multiple threads to read protocol
283;; back from the frontend.
284(define gds-read-mutex (make-mutex))
285
286;; Read a protocol instruction from the frontend.
287(define (gds-read)
288  ;; Acquire the read mutex.
289  (lock-mutex gds-read-mutex)
290  ;; Tell the front end something that identifies us as a thread.
291  (write-form `(thread-id ,(get-thread-id)))
292  ;; Now read, then release the mutex and return what was read.
293  (let ((x (catch #t
294		  (lambda () (read gds-port))
295		  (lambda ignored the-eof-object))))
296    (unlock-mutex gds-read-mutex)
297    x))
298
299(define (gds-accept-input exit-on-continue)
300  ;; If reading from the GDS connection returns EOF, we will throw to
301  ;; this catch.
302  (catch 'server-eof
303    (lambda ()
304      (let loop ((protocol (gds-read)))
305        (if (or (eof-object? protocol)
306		(and exit-on-continue
307		     (eq? (car protocol) 'continue)))
308	    (throw 'server-eof))
309        (safely-handle-nondebug-protocol protocol)
310        (loop (gds-read))))
311    (lambda ignored #f)))
312
313(define (safely-handle-nondebug-protocol protocol)
314  ;; This catch covers any internal errors in the GDS code or
315  ;; protocol.
316  (catch #t
317    (lambda ()
318      (lazy-catch #t
319        (lambda ()
320          (handle-nondebug-protocol protocol))
321        save-lazy-trap-context-and-rethrow))
322    (lambda (key . args)
323      (write-form
324       `(eval-results (error . ,(format #f "~s" protocol))
325                      ,(if last-lazy-trap-context 't 'nil)
326                      "GDS Internal Error
327Please report this to <neil@ossau.uklinux.net>, ideally including:
328- a description of the scenario in which this error occurred
329- which versions of Guile and guile-debugging you are using
330- the error stack, which you can get by clicking on the link below,
331  and then cut and paste into your report.
332Thanks!\n\n"
333                      ,(list (with-output-to-string
334                               (lambda ()
335                                 (write key)
336                                 (display ": ")
337                                 (write args)
338                                 (newline)))))))))
339
340;; The key that is used to signal a read error changes from 1.6 to
341;; 1.8; here we cover all eventualities by discovering the key
342;; dynamically.
343(define read-error-key
344  (catch #t
345    (lambda ()
346      (with-input-from-string "(+ 3 4" read))
347    (lambda (key . args)
348      key)))
349
350(define (handle-nondebug-protocol protocol)
351  (case (car protocol)
352
353    ((eval)
354     (set! last-lazy-trap-context #f)
355     (apply (lambda (correlator module port-name line column code flags)
356              (with-input-from-string code
357                (lambda ()
358                  (set-port-filename! (current-input-port) port-name)
359                  (set-port-line! (current-input-port) line)
360                  (set-port-column! (current-input-port) column)
361                  (let ((m (and module (resolve-module-from-root module))))
362                    (catch read-error-key
363                      (lambda ()
364                        (let loop ((exprs '()) (x (read)))
365                          (if (eof-object? x)
366                              ;; Expressions to be evaluated have all
367                              ;; been read.  Now evaluate them.
368                              (let loop2 ((exprs (reverse! exprs))
369                                          (results '())
370                                          (n 1))
371                                (if (null? exprs)
372                                    (write-form `(eval-results ,correlator
373                                                               ,(if last-lazy-trap-context 't 'nil)
374                                                               ,@results))
375                                    (loop2 (cdr exprs)
376                                           (append results (gds-eval (car exprs) m
377                                                                     (if (and (null? (cdr exprs))
378                                                                              (= n 1))
379                                                                         #f n)))
380                                           (+ n 1))))
381                              ;; Another complete expression read; add
382                              ;; it to the list.
383			      (begin
384				(if (and (pair? x)
385					 (memq 'debug flags))
386				    (install-trap (make <source-trap>
387						    #:expression x
388						    #:behaviour gds-debug-trap)))
389				(loop (cons x exprs) (read))))))
390                      (lambda (key . args)
391                        (write-form `(eval-results
392                                      ,correlator
393                                      ,(if last-lazy-trap-context 't 'nil)
394                                      ,(with-output-to-string
395                                         (lambda ()
396                                           (display ";;; Reading expressions")
397                                           (display " to evaluate\n")
398                                           (apply display-error #f
399                                                  (current-output-port) args)))
400                                      ("error-in-read")))))))))
401            (cdr protocol)))
402
403    ((complete)
404     (let ((matches (apropos-internal
405		     (string-append "^" (regexp-quote (cadr protocol))))))
406       (cond ((null? matches)
407	      (write-form '(completion-result nil)))
408	     (else
409	      ;;(write matches (current-error-port))
410	      ;;(newline (current-error-port))
411	      (let ((match
412		     (let loop ((match (symbol->string (car matches)))
413				(matches (cdr matches)))
414		       ;;(write match (current-error-port))
415		       ;;(newline (current-error-port))
416		       ;;(write matches (current-error-port))
417		       ;;(newline (current-error-port))
418		       (if (null? matches)
419			   match
420			   (if (string-prefix=? match
421						(symbol->string (car matches)))
422			       (loop match (cdr matches))
423			       (loop (substring match 0
424						(- (string-length match) 1))
425				     matches))))))
426		(if (string=? match (cadr protocol))
427		    (write-form `(completion-result
428				  ,(map symbol->string matches)))
429		    (write-form `(completion-result
430				  ,match))))))))
431
432    ((debug-lazy-trap-context)
433     (if last-lazy-trap-context
434         (gds-debug-trap last-lazy-trap-context)
435         (error "There is no stack available to show")))
436
437    (else
438     (error "Unexpected protocol:" protocol))))
439
440(define (resolve-module-from-root name)
441  (save-module-excursion
442   (lambda ()
443     (set-current-module the-root-module)
444     (resolve-module name))))
445
446(define (gds-eval x m part)
447  ;; Consumer to accept possibly multiple values and present them for
448  ;; Emacs as a list of strings.
449  (define (value-consumer . values)
450    (if (unspecified? (car values))
451	'()
452	(map (lambda (value)
453	       (with-output-to-string (lambda () (write value))))
454	     values)))
455  ;; Now do evaluation.
456  (let ((intro (if part
457		   (format #f ";;; Evaluating expression ~A" part)
458		   ";;; Evaluating"))
459	(value #f))
460    (let* ((do-eval (if m
461			(lambda ()
462			  (display intro)
463			  (display " in module ")
464			  (write (module-name m))
465			  (newline)
466			  (set! value
467				(call-with-values (lambda ()
468						    (start-stack 'gds-eval-stack
469								 (eval x m)))
470				  value-consumer)))
471			(lambda ()
472			  (display intro)
473			  (display " in current module ")
474			  (write (module-name (current-module)))
475			  (newline)
476			  (set! value
477				(call-with-values (lambda ()
478						    (start-stack 'gds-eval-stack
479								 (primitive-eval x)))
480				  value-consumer)))))
481	   (output
482	    (with-output-to-string
483	     (lambda ()
484	       (catch #t
485                 (lambda ()
486                   (lazy-catch #t
487                     do-eval
488                     save-lazy-trap-context-and-rethrow))
489                 (lambda (key . args)
490                   (case key
491                     ((misc-error signal unbound-variable numerical-overflow)
492                      (apply display-error #f
493                             (current-output-port) args)
494                      (set! value '("error-in-evaluation")))
495                     (else
496                      (display "EXCEPTION: ")
497                      (display key)
498                      (display " ")
499                      (write args)
500                      (newline)
501                      (set! value
502                            '("unhandled-exception-in-evaluation"))))))))))
503      (list output value))))
504
505(define last-lazy-trap-context #f)
506
507(define (save-lazy-trap-context-and-rethrow key . args)
508  (set! last-lazy-trap-context
509	(throw->trap-context key args save-lazy-trap-context-and-rethrow))
510  (apply throw key args))
511
512(define (run-utility)
513  (connect-to-gds)
514  (write (getpid))
515  (newline)
516  (force-output)
517  (named-module-use! '(guile-user) '(ice-9 session))
518  (gds-accept-input #f))
519
520(define-method (trap-description (trap <trap>))
521  (let loop ((description (list (class-name (class-of trap))))
522	     (next 'installed?))
523    (case next
524      ((installed?)
525       (loop (if (slot-ref trap 'installed)
526		 (cons 'installed description)
527		 description)
528	     'conditional?))
529      ((conditional?)
530       (loop (if (slot-ref trap 'condition)
531		 (cons 'conditional description)
532		 description)
533	     'skip-count))
534      ((skip-count)
535       (loop (let ((skip-count (slot-ref trap 'skip-count)))
536	       (if (zero? skip-count)
537		   description
538		   (cons* skip-count 'skip-count description)))
539	     'single-shot?))
540      ((single-shot?)
541       (loop (if (slot-ref trap 'single-shot)
542		 (cons 'single-shot description)
543		 description)
544	     'done))
545      (else
546       (reverse! description)))))
547
548(define-method (trap-description (trap <procedure-trap>))
549  (let ((description (next-method)))
550    (set-cdr! description
551	      (cons (procedure-name (slot-ref trap 'procedure))
552		    (cdr description)))
553    description))
554
555(define-method (trap-description (trap <source-trap>))
556  (let ((description (next-method)))
557    (set-cdr! description
558	      (cons (format #f "~s" (slot-ref trap 'expression))
559		    (cdr description)))
560    description))
561
562(define-method (trap-description (trap <location-trap>))
563  (let ((description (next-method)))
564    (set-cdr! description
565	      (cons* (slot-ref trap 'file-regexp)
566		     (slot-ref trap 'line)
567		     (slot-ref trap 'column)
568		     (cdr description)))
569    description))
570
571(define (gds-trace-trap trap-context)
572  (connect-to-gds)
573  (gds-do-trace trap-context)
574  (at-exit (tc:depth trap-context) gds-do-trace))
575
576(define (gds-do-trace trap-context)
577  (write-form (list 'trace
578		    (format #f
579			    "~3@a: ~a"
580			    (trace/stack-real-depth trap-context)
581			    (trace/info trap-context)))))
582
583(define (gds-trace-subtree trap-context)
584  (connect-to-gds)
585  (gds-do-trace trap-context)
586  (let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
587    (install-trap step-trap)
588    (at-exit (tc:depth trap-context)
589	     (lambda (trap-context)
590	       (uninstall-trap step-trap)))))
591
592;;; (ice-9 gds-client) ends here.
593