mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
049ec20299
* module/ice-9/boot-9.scm: * module/ice-9/deprecated.scm (named-module-use!) (load-emacs-interface): Deprecate these. * module/ice-9/gds-client.scm (run-utility): Redefine to not use named-module-use!. * libguile/script.c (scm_shell_usage): Remove --emacs option. (scm_compile_shell_switches): Remove support for --emacs. * module/ice-9/boot-9.scm (top-repl): Don't muck with --emacs. * doc/ref/scheme-scripts.texi (Invoking Guile): Remove note about --emacs.
583 lines
21 KiB
Scheme
Executable file
583 lines
21 KiB
Scheme
Executable file
(define-module (ice-9 gds-client)
|
|
#:use-module (oop goops)
|
|
#:use-module (oop goops describe)
|
|
#: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
|
|
gds-accept-input))
|
|
|
|
(use-modules (ice-9 debugger utils))
|
|
|
|
(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
|
|
(let ((gds-unix-socket-name (getenv "GDS_UNIX_SOCKET_NAME")))
|
|
(set! gds-port
|
|
(or (and gds-unix-socket-name
|
|
(false-if-exception
|
|
(let ((s (socket PF_UNIX SOCK_STREAM 0)))
|
|
(connect s AF_UNIX gds-unix-socket-name)
|
|
s)))
|
|
(false-if-exception
|
|
(let ((s (socket PF_INET SOCK_STREAM 0))
|
|
(SOL_TCP 6)
|
|
(TCP_NODELAY 1))
|
|
(setsockopt s SOL_TCP TCP_NODELAY 1)
|
|
(connect s AF_INET (inet-aton "127.0.0.1") 8333)
|
|
s))
|
|
(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)))
|
|
|
|
;; FIXME: the new evaluator breaks this, by removing local-eval. Need to
|
|
;; figure out our story in this regard.
|
|
(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
|
|
(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")))))))))
|
|
(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")))
|
|
|
|
(else
|
|
(error "Unexpected protocol:" protocol))))
|
|
|
|
(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)
|
|
(connect-to-gds)
|
|
(write (getpid))
|
|
(newline)
|
|
(force-output)
|
|
(module-use! (resolve-module '(guile-user))
|
|
(resolve-interface '(ice-9 session)))
|
|
(gds-accept-input #f))
|
|
|
|
(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.
|