[bpt/guile.git] / ice-9 / gds-client.scm

(define-module (ice-9 gds-client)
  #:use-module (oop goops)
  #:use-module (oop goops describe)
  #:use-module (ice-9 debugging breakpoints)
  #:use-module (ice-9 debugging trace)
  #:use-module (ice-9 debugging traps)
  #:use-module (ice-9 debugging trc)
  #:use-module (ice-9 debugging steps)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 session)
  #:use-module (ice-9 string-fun)
  #:export (gds-debug-trap
	    run-utility
	    set-gds-breakpoints
	    gds-accept-input))

(cond ((string>=? (version) "1.7")
       (use-modules (ice-9 debugger utils)))
      (else
       (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
       (module-export! the-ice-9-debugger-module
		       '(source-position
			 write-frame-short/application
			 write-frame-short/expression
			 write-frame-args-long
			 write-frame-long))))

(use-modules (ice-9 debugger))

(define gds-port #f)

;; Return an integer that somehow identifies the current thread.
(define (get-thread-id)
  (let ((root (dynamic-root)))
    (cond ((integer? root)
	   root)
	  ((pair? root)
	   (object-address root))
	  (else
	   (error "Unexpected dynamic root:" root)))))

;; gds-debug-read is a high-priority read.  The (debug-thread-id ID)
;; form causes the frontend to dismiss any reads from threads whose id
;; is not ID, until it receives the (thread-id ...) form with the same
;; id as ID.  Dismissing the reads of any other threads (by sending a
;; form that is otherwise ignored) causes those threads to release the
;; read mutex, which allows the (gds-read) here to proceed.
(define (gds-debug-read)
  (write-form `(debug-thread-id ,(get-thread-id)))
  (gds-read))

(define (gds-debug-trap trap-context)
  "Invoke the GDS debugger to explore the stack at the specified trap."
  (connect-to-gds)
  (start-stack 'debugger
               (let* ((stack (tc:stack trap-context))
		      (flags1 (let ((trap-type (tc:type trap-context)))
				(case trap-type
				  ((#:return #:error)
				   (list trap-type
					 (tc:return-value trap-context)))
				  (else
				   (list trap-type)))))
		      (flags (if (tc:continuation trap-context)
				 (cons #:continuable flags1)
				 flags1))
		      (fired-traps (tc:fired-traps trap-context))
		      (special-index (and (= (length fired-traps) 1)
					  (is-a? (car fired-traps) <exit-trap>)
					  (eq? (tc:type trap-context) #:return)
					  (- (tc:depth trap-context)
					     (slot-ref (car fired-traps) 'depth)))))
                 ;; Write current stack to the frontend.
                 (write-form (list 'stack
				   (if (and special-index (> special-index 0))
				       special-index
				       0)
                                   (stack->emacs-readable stack)
                                   (append (flags->emacs-readable flags)
                                           (slot-ref trap-context
                                                     'handler-return-syms))))
		 ;; Now wait for instruction.
                 (let loop ((protocol (gds-debug-read)))
                   ;; Act on it.
                   (case (car protocol)
                     ((tweak)
		      ;; Request to tweak the handler return value.
		      (let ((tweaking (catch #t
					     (lambda ()
					       (list (with-input-from-string
							 (cadr protocol)
						       read)))
					     (lambda ignored #f))))
			(if tweaking
			    (slot-set! trap-context
				       'handler-return-value
				       (cons 'instead (car tweaking)))))
                      (loop (gds-debug-read)))
                     ((continue)
                      ;; Continue (by exiting the debugger).
                      *unspecified*)
                     ((evaluate)
                      ;; Evaluate expression in specified frame.
                      (eval-in-frame stack (cadr protocol) (caddr protocol))
                      (loop (gds-debug-read)))
                     ((info-frame)
                      ;; Return frame info.
                      (let ((frame (stack-ref stack (cadr protocol))))
                        (write-form (list 'info-result
                                          (with-output-to-string
                                            (lambda ()
                                              (write-frame-long frame))))))
                      (loop (gds-debug-read)))
                     ((info-args)
                      ;; Return frame args.
                      (let ((frame (stack-ref stack (cadr protocol))))
                        (write-form (list 'info-result
                                          (with-output-to-string
                                            (lambda ()
                                              (write-frame-args-long frame))))))
                      (loop (gds-debug-read)))
                     ((proc-source)
                      ;; Show source of application procedure.
                      (let* ((frame (stack-ref stack (cadr protocol)))
                             (proc (frame-procedure frame))
                             (source (and proc (procedure-source proc))))
                        (write-form (list 'info-result
                                          (if source
                                              (sans-surrounding-whitespace
                                               (with-output-to-string
                                                 (lambda ()
                                                   (pretty-print source))))
                                              (if proc
                                                  "This procedure is coded in C"
                                                  "This frame has no procedure")))))
                      (loop (gds-debug-read)))
		     ((traps-here)
		      ;; Show the traps that fired here.
		      (write-form (list 'info-result
					(with-output-to-string
					  (lambda ()
					    (for-each describe
						 (tc:fired-traps trap-context))))))
		      (loop (gds-debug-read)))
                     ((step-into)
                      ;; Set temporary breakpoint on next trap.
                      (at-step gds-debug-trap
                               1
			       #f
			       (if (memq #:return flags)
				   #f
				   (- (stack-length stack)
				      (cadr protocol)))))
                     ((step-over)
                      ;; Set temporary breakpoint on exit from
                      ;; specified frame.
                      (at-exit (- (stack-length stack) (cadr protocol))
                               gds-debug-trap))
                     ((step-file)
                      ;; Set temporary breakpoint on next trap in same
                      ;; source file.
                      (at-step gds-debug-trap
                               1
                               (frame-file-name (stack-ref stack
                                                           (cadr protocol)))
			       (if (memq #:return flags)
				   #f
				   (- (stack-length stack)
				      (cadr protocol)))))
                     (else
                      (safely-handle-nondebug-protocol protocol)
                      (loop (gds-debug-read))))))))

(define (connect-to-gds . application-name)
  (or gds-port
      (begin
        (set! gds-port
	      (or (let ((s (socket PF_INET SOCK_STREAM 0))
			(SOL_TCP 6)
			(TCP_NODELAY 1))
		    (setsockopt s SOL_TCP TCP_NODELAY 1)
		    (catch #t
			   (lambda ()
			     (connect s AF_INET (inet-aton "127.0.0.1") 8333)
			     s)
			   (lambda _ #f)))
		  (let ((s (socket PF_UNIX SOCK_STREAM 0)))
		    (catch #t
			   (lambda ()
			     (connect s AF_UNIX "/tmp/.gds_socket")
			     s)
			   (lambda _ #f)))
		  (error "Couldn't connect to GDS by TCP or Unix domain socket")))
        (write-form (list 'name (getpid) (apply client-name application-name))))))

(define (client-name . application-name)
  (let loop ((args (append application-name (program-arguments))))
    (if (null? args)
	(format #f "PID ~A" (getpid))
	(let ((arg (car args)))
	  (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
		 (loop (cdr args)))
		((string-match "^-" arg)
		 (loop (cdr args)))
		(else
		 (format #f "~A (PID ~A)" arg (getpid))))))))

(if (not (defined? 'make-mutex))
    (begin
      (define (make-mutex) #f)
      (define lock-mutex noop)
      (define unlock-mutex noop)))

(define write-mutex (make-mutex))

(define (write-form form)
  ;; Write any form FORM to GDS.
  (lock-mutex write-mutex)
  (write form gds-port)
  (newline gds-port)
  (force-output gds-port)
  (unlock-mutex write-mutex))

(define (stack->emacs-readable stack)
  ;; Return Emacs-readable representation of STACK.
  (map (lambda (index)
	 (frame->emacs-readable (stack-ref stack index)))
       (iota (min (stack-length stack)
		  (cadr (memq 'depth (debug-options)))))))

(define (frame->emacs-readable frame)
  ;; Return Emacs-readable representation of FRAME.
  (if (frame-procedure? frame)
      (list 'application
	    (with-output-to-string
	     (lambda ()
	       (display (if (frame-real? frame) "  " "t "))
	       (write-frame-short/application frame)))
	    (source->emacs-readable frame))
      (list 'evaluation
	    (with-output-to-string
	     (lambda ()
	       (display (if (frame-real? frame) "  " "t "))
	       (write-frame-short/expression frame)))
	    (source->emacs-readable frame))))

(define (source->emacs-readable frame)
  ;; Return Emacs-readable representation of the filename, line and
  ;; column source properties of SOURCE.
  (or (frame->source-position frame) 'nil))

(define (flags->emacs-readable flags)
  ;; Return Emacs-readable representation of trap FLAGS.
  (let ((prev #f))
    (map (lambda (flag)
	   (let ((erf (if (and (keyword? flag)
			       (not (eq? prev #:return)))
			  (keyword->symbol flag)
			  (format #f "~S" flag))))
	     (set! prev flag)
	     erf))
	 flags)))

(define (eval-in-frame stack index expr)
  (write-form
   (list 'eval-result
         (format #f "~S"
                 (catch #t
                        (lambda ()
                          (local-eval (with-input-from-string expr read)
                                      (memoized-environment
                                       (frame-source (stack-ref stack
                                                                index)))))
                        (lambda args
                          (cons 'ERROR args)))))))

(set! (behaviour-ordering gds-debug-trap) 100)

;;; Code below here adds support for interaction between the GDS
;;; client program and the Emacs frontend even when not stopped in the
;;; debugger.

;; A mutex to control attempts by multiple threads to read protocol
;; back from the frontend.
(define gds-read-mutex (make-mutex))

;; Read a protocol instruction from the frontend.
(define (gds-read)
  ;; Acquire the read mutex.
  (lock-mutex gds-read-mutex)
  ;; Tell the front end something that identifies us as a thread.
  (write-form `(thread-id ,(get-thread-id)))
  ;; Now read, then release the mutex and return what was read.
  (let ((x (catch #t
		  (lambda () (read gds-port))
		  (lambda ignored the-eof-object))))
    (unlock-mutex gds-read-mutex)
    x))

(define (gds-accept-input exit-on-continue)
  ;; If reading from the GDS connection returns EOF, we will throw to
  ;; this catch.
  (catch 'server-eof
    (lambda ()
      (let loop ((protocol (gds-read)))
        (if (or (eof-object? protocol)
		(and exit-on-continue
		     (eq? (car protocol) 'continue)))
	    (throw 'server-eof))
        (safely-handle-nondebug-protocol protocol)
        (loop (gds-read))))
    (lambda ignored #f)))

(define (safely-handle-nondebug-protocol protocol)
  ;; This catch covers any internal errors in the GDS code or
  ;; protocol.
  (catch #t
    (lambda ()
      (lazy-catch #t
        (lambda ()
          (handle-nondebug-protocol protocol))
        save-lazy-trap-context-and-rethrow))
    (lambda (key . args)
      (write-form
       `(eval-results (error . ,(format #f "~s" protocol))
                      ,(if last-lazy-trap-context 't 'nil)
                      "GDS Internal Error
Please report this to <neil@ossau.uklinux.net>, ideally including:
- a description of the scenario in which this error occurred
- which versions of Guile and guile-debugging you are using
- the error stack, which you can get by clicking on the link below,
  and then cut and paste into your report.
Thanks!\n\n"
                      ,(list (with-output-to-string
                               (lambda ()
                                 (write key)
                                 (display ": ")
                                 (write args)
                                 (newline)))))))))

;; The key that is used to signal a read error changes from 1.6 to
;; 1.8; here we cover all eventualities by discovering the key
;; dynamically.
(define read-error-key
  (catch #t
    (lambda ()
      (with-input-from-string "(+ 3 4" read))
    (lambda (key . args)
      key)))

(define (handle-nondebug-protocol protocol)
  (case (car protocol)

    ((eval)
     (set! last-lazy-trap-context #f)
     (apply (lambda (correlator module port-name line column code flags)
              (with-input-from-string code
                (lambda ()
                  (set-port-filename! (current-input-port) port-name)
                  (set-port-line! (current-input-port) line)
                  (set-port-column! (current-input-port) column)
                  (let ((m (and module (resolve-module-from-root module))))
                    (catch read-error-key
                      (lambda ()
                        (let loop ((exprs '()) (x (read)))
                          (if (eof-object? x)
                              ;; Expressions to be evaluated have all
                              ;; been read.  Now evaluate them.
                              (let loop2 ((exprs (reverse! exprs))
                                          (results '())
                                          (n 1))
                                (if (null? exprs)
                                    (write-form `(eval-results ,correlator
                                                               ,(if last-lazy-trap-context 't 'nil)
                                                               ,@results))
                                    (loop2 (cdr exprs)
                                           (append results (gds-eval (car exprs) m
                                                                     (if (and (null? (cdr exprs))
                                                                              (= n 1))
                                                                         #f n)))
                                           (+ n 1))))
                              ;; Another complete expression read; add
                              ;; it to the list.
			      (begin
				(for-each-breakpoint setup-after-read x)
				(if (and (pair? x)
					 (memq 'debug flags))
				    (install-trap (make <source-trap>
						    #:expression x
						    #:behaviour gds-debug-trap)))
				(loop (cons x exprs) (read))))))
                      (lambda (key . args)
                        (write-form `(eval-results
                                      ,correlator
                                      ,(if last-lazy-trap-context 't 'nil)
                                      ,(with-output-to-string
                                         (lambda ()
                                           (display ";;; Reading expressions")
                                           (display " to evaluate\n")
                                           (apply display-error #f
                                                  (current-output-port) args)))
                                      ("error-in-read"))))))))
	      (if (string? port-name)
		  (without-traps
		   (lambda ()
		     (for-each-breakpoint setup-after-eval port-name)))))
            (cdr protocol)))

    ((complete)
     (let ((matches (apropos-internal
		     (string-append "^" (regexp-quote (cadr protocol))))))
       (cond ((null? matches)
	      (write-form '(completion-result nil)))
	     (else
	      ;;(write matches (current-error-port))
	      ;;(newline (current-error-port))
	      (let ((match
		     (let loop ((match (symbol->string (car matches)))
				(matches (cdr matches)))
		       ;;(write match (current-error-port))
		       ;;(newline (current-error-port))
		       ;;(write matches (current-error-port))
		       ;;(newline (current-error-port))
		       (if (null? matches)
			   match
			   (if (string-prefix=? match
						(symbol->string (car matches)))
			       (loop match (cdr matches))
			       (loop (substring match 0
						(- (string-length match) 1))
				     matches))))))
		(if (string=? match (cadr protocol))
		    (write-form `(completion-result
				  ,(map symbol->string matches)))
		    (write-form `(completion-result
				  ,match))))))))

    ((debug-lazy-trap-context)
     (if last-lazy-trap-context
         (gds-debug-trap last-lazy-trap-context)
         (error "There is no stack available to show")))

    ((set-breakpoint)
     ;; Create or update a breakpoint object according to the
     ;; definition.  If the target code is already loaded, note that
     ;; this may immediately install a trap.
     (let* ((num (cadr protocol))
	    (def (caddr protocol))
	    (behaviour (case (list-ref def 0)
			 ((debug) gds-debug-trap)
			 ((trace) gds-trace-trap)
			 ((trace-subtree) gds-trace-subtree)
			 (else (error "Unsupported behaviour:"
				      (list-ref def 0)))))
	    (bp (hash-ref breakpoints num)))
       (trc 'existing-bp bp)
       (if bp
	   (update-breakpoint bp (list-ref def 3))
	   (begin
	     (set! bp
		   (case (list-ref def 1)
		     ((in)
		      (break-in (string->symbol (list-ref def 3))
				(list-ref def 2)
				#:behaviour behaviour))
		     ((at)
		      (break-at (list-ref def 2)
				(car (list-ref def 3))
				(cdr (list-ref def 3))
				#:behaviour behaviour))
		     (else
		      (error "Unsupported breakpoint type:"
			     (list-ref def 1)))))
	     ;; Install an observer that will tell the frontend about
	     ;; future changes in this breakpoint's status.
	     (slot-set! bp 'observer
			(lambda ()
			  (write-form `(breakpoint
					,num
					,@(map trap-description
					       (slot-ref bp 'traps))))))
	     ;; Add this to the breakpoint hash, and return the
	     ;; breakpoint number and status to the front end.
	     (hash-set! breakpoints num bp)))
       ;; Call the breakpoint's observer now.
       ((slot-ref bp 'observer))))

    ((delete-breakpoint)
     (let* ((num (cadr protocol))
	    (bp (hash-ref breakpoints num)))
       (if bp
	   (begin
	     (hash-remove! breakpoints num)
	     (delete-breakpoint bp)))))

;;;    ((describe-breakpoints)
;;;     ;; Describe all breakpoints.
;;;     (let ((desc
;;;	    (with-output-to-string
;;;	      (lambda ()
;;;		(hash-fold (lambda (num bp acc)
;;;			     (format #t
;;;				     "Breakpoint ~a ~a (~a):\n"
;;;				     (class-name (class-of bp))
;;;				     num
;;;				     (slot-ref bp 'status))
;;;			     (for-each (lambda (trap)
;;;					 (write (trap-description trap))
;;;					 (newline))
;;;				       (slot-ref bp 'traps)))
;;;			   #f
;;;			   breakpoints)))))
;;;       (write-form (list 'info-result desc))))

    (else
     (error "Unexpected protocol:" protocol))))

(define breakpoints (make-hash-table 11))

(define (resolve-module-from-root name)
  (save-module-excursion
   (lambda ()
     (set-current-module the-root-module)
     (resolve-module name))))

(define (gds-eval x m part)
  ;; Consumer to accept possibly multiple values and present them for
  ;; Emacs as a list of strings.
  (define (value-consumer . values)
    (if (unspecified? (car values))
	'()
	(map (lambda (value)
	       (with-output-to-string (lambda () (write value))))
	     values)))
  ;; Now do evaluation.
  (let ((intro (if part
		   (format #f ";;; Evaluating expression ~A" part)
		   ";;; Evaluating"))
	(value #f))
    (let* ((do-eval (if m
			(lambda ()
			  (display intro)
			  (display " in module ")
			  (write (module-name m))
			  (newline)
			  (set! value
				(call-with-values (lambda ()
						    (start-stack 'gds-eval-stack
								 (eval x m)))
				  value-consumer)))
			(lambda ()
			  (display intro)
			  (display " in current module ")
			  (write (module-name (current-module)))
			  (newline)
			  (set! value
				(call-with-values (lambda ()
						    (start-stack 'gds-eval-stack
								 (primitive-eval x)))
				  value-consumer)))))
	   (output
	    (with-output-to-string
	     (lambda ()
	       (catch #t
                 (lambda ()
                   (lazy-catch #t
                     do-eval
                     save-lazy-trap-context-and-rethrow))
                 (lambda (key . args)
                   (case key
                     ((misc-error signal unbound-variable numerical-overflow)
                      (apply display-error #f
                             (current-output-port) args)
                      (set! value '("error-in-evaluation")))
                     (else
                      (display "EXCEPTION: ")
                      (display key)
                      (display " ")
                      (write args)
                      (newline)
                      (set! value
                            '("unhandled-exception-in-evaluation"))))))))))
      (list output value))))

(define last-lazy-trap-context #f)

(define (save-lazy-trap-context-and-rethrow key . args)
  (set! last-lazy-trap-context
	(throw->trap-context key args save-lazy-trap-context-and-rethrow))
  (apply throw key args))

(define (run-utility)
  (set-gds-breakpoints)
  (write (getpid))
  (newline)
  (force-output)
  (named-module-use! '(guile-user) '(ice-9 session))
  (gds-accept-input #f))

(define (set-gds-breakpoints)
  (connect-to-gds)
  (write-form '(get-breakpoints))
  (gds-accept-input #t))

(define-method (trap-description (trap <trap>))
  (let loop ((description (list (class-name (class-of trap))))
	     (next 'installed?))
    (case next
      ((installed?)
       (loop (if (slot-ref trap 'installed)
		 (cons 'installed description)
		 description)
	     'conditional?))
      ((conditional?)
       (loop (if (slot-ref trap 'condition)
		 (cons 'conditional description)
		 description)
	     'skip-count))
      ((skip-count)
       (loop (let ((skip-count (slot-ref trap 'skip-count)))
	       (if (zero? skip-count)
		   description
		   (cons* skip-count 'skip-count description)))
	     'single-shot?))
      ((single-shot?)
       (loop (if (slot-ref trap 'single-shot)
		 (cons 'single-shot description)
		 description)
	     'done))
      (else
       (reverse! description)))))

(define-method (trap-description (trap <procedure-trap>))
  (let ((description (next-method)))
    (set-cdr! description
	      (cons (procedure-name (slot-ref trap 'procedure))
		    (cdr description)))
    description))

(define-method (trap-description (trap <source-trap>))
  (let ((description (next-method)))
    (set-cdr! description
	      (cons (format #f "~s" (slot-ref trap 'expression))
		    (cdr description)))
    description))

(define-method (trap-description (trap <location-trap>))
  (let ((description (next-method)))
    (set-cdr! description
	      (cons* (slot-ref trap 'file-regexp)
		     (slot-ref trap 'line)
		     (slot-ref trap 'column)
		     (cdr description)))
    description))

(define (gds-trace-trap trap-context)
  (connect-to-gds)
  (gds-do-trace trap-context)
  (at-exit (tc:depth trap-context) gds-do-trace))

(define (gds-do-trace trap-context)
  (write-form (list 'trace
		    (format #f
			    "~3@a: ~a"
			    (trace/stack-real-depth trap-context)
			    (trace/info trap-context)))))

(define (gds-trace-subtree trap-context)
  (connect-to-gds)
  (gds-do-trace trap-context)
  (let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
    (install-trap step-trap)
    (at-exit (tc:depth trap-context)
	     (lambda (trap-context)
	       (uninstall-trap step-trap)))))

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