ice-9/gds-client.scm

   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
  76                                    (or special-index 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)
 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) (format #f "PID ~A" (getpid)))))))
 194
 195 (if (not (defined? 'make-mutex))
 196     (begin
 197       (define (make-mutex) #f)
 198       (define lock-mutex noop)
 199       (define unlock-mutex noop)))
 200
 201 (define write-mutex (make-mutex))
 202
 203 (define (write-form form)
 204   ;; Write any form FORM to GDS.
 205   (lock-mutex write-mutex)
 206   (write form gds-port)
 207   (newline gds-port)
 208   (force-output gds-port)
 209   (unlock-mutex write-mutex))
 210
 211 (define (stack->emacs-readable stack)
 212   ;; Return Emacs-readable representation of STACK.
 213   (map (lambda (index)
 214          (frame->emacs-readable (stack-ref stack index)))
 215        (iota (min (stack-length stack)
 216                   (cadr (memq 'depth (debug-options)))))))
 217
 218 (define (frame->emacs-readable frame)
 219   ;; Return Emacs-readable representation of FRAME.
 220   (if (frame-procedure? frame)
 221       (list 'application
 222             (with-output-to-string
 223              (lambda ()
 224                (display (if (frame-real? frame) "  " "t "))
 225                (write-frame-short/application frame)))
 226             (source->emacs-readable frame))
 227       (list 'evaluation
 228             (with-output-to-string
 229              (lambda ()
 230                (display (if (frame-real? frame) "  " "t "))
 231                (write-frame-short/expression frame)))
 232             (source->emacs-readable frame))))
 233
 234 (define (source->emacs-readable frame)
 235   ;; Return Emacs-readable representation of the filename, line and
 236   ;; column source properties of SOURCE.
 237   (or (frame->source-position frame) 'nil))
 238
 239 (define (flags->emacs-readable flags)
 240   ;; Return Emacs-readable representation of trap FLAGS.
 241   (let ((prev #f))
 242     (map (lambda (flag)
 243            (let ((erf (if (and (keyword? flag)
 244                                (not (eq? prev #:return)))
 245                           (keyword->symbol flag)
 246                           (format #f "~S" flag))))
 247              (set! prev flag)
 248              erf))
 249          flags)))
 250
 251 (define (eval-in-frame stack index expr)
 252   (write-form
 253    (list 'eval-result
 254          (format #f "~S"
 255                  (catch #t
 256                         (lambda ()
 257                           (local-eval (with-input-from-string expr read)
 258                                       (memoized-environment
 259                                        (frame-source (stack-ref stack
 260                                                                 index)))))
 261                         (lambda args
 262                           (cons 'ERROR args)))))))
 263
 264 (set! (behaviour-ordering gds-debug-trap) 100)
 265
 266 ;;; Code below here adds support for interaction between the GDS
 267 ;;; client program and the Emacs frontend even when not stopped in the
 268 ;;; debugger.
 269
 270 ;; A mutex to control attempts by multiple threads to read protocol
 271 ;; back from the frontend.
 272 (define gds-read-mutex (make-mutex))
 273
 274 ;; Read a protocol instruction from the frontend.
 275 (define (gds-read)
 276   ;; Acquire the read mutex.
 277   (lock-mutex gds-read-mutex)
 278   ;; Tell the front end something that identifies us as a thread.
 279   (write-form `(thread-id ,(get-thread-id)))
 280   ;; Now read, then release the mutex and return what was read.
 281   (let ((x (catch #t
 282                   (lambda () (read gds-port))
 283                   (lambda ignored the-eof-object))))
 284     (unlock-mutex gds-read-mutex)
 285     x))
 286
 287 (define (gds-accept-input exit-on-continue)
 288   ;; If reading from the GDS connection returns EOF, we will throw to
 289   ;; this catch.
 290   (catch 'server-eof
 291     (lambda ()
 292       (let loop ((protocol (gds-read)))
 293         (if (or (eof-object? protocol)
 294                 (and exit-on-continue
 295                      (eq? (car protocol) 'continue)))
 296             (throw 'server-eof))
 297         (safely-handle-nondebug-protocol protocol)
 298         (loop (gds-read))))
 299     (lambda ignored #f)))
 300
 301 (define (safely-handle-nondebug-protocol protocol)
 302   ;; This catch covers any internal errors in the GDS code or
 303   ;; protocol.
 304   (catch #t
 305     (lambda ()
 306       (lazy-catch #t
 307         (lambda ()
 308           (handle-nondebug-protocol protocol))
 309         save-lazy-trap-context-and-rethrow))
 310     (lambda (key . args)
 311       (write-form
 312        `(eval-results (error . ,(format #f "~s" protocol))
 313                       ,(if last-lazy-trap-context 't 'nil)
 314                       "GDS Internal Error
 315 Please report this to <neil@ossau.uklinux.net>, ideally including:
 316 - a description of the scenario in which this error occurred
 317 - which versions of Guile and guile-debugging you are using
 318 - the error stack, which you can get by clicking on the link below,
 319   and then cut and paste into your report.
 320 Thanks!\n\n"
 321                       ,(list (with-output-to-string
 322                                (lambda ()
 323                                  (write key)
 324                                  (display ": ")
 325                                  (write args)
 326                                  (newline)))))))))
 327
 328 ;; The key that is used to signal a read error changes from 1.6 to
 329 ;; 1.8; here we cover all eventualities by discovering the key
 330 ;; dynamically.
 331 (define read-error-key
 332   (catch #t
 333     (lambda ()
 334       (with-input-from-string "(+ 3 4" read))
 335     (lambda (key . args)
 336       key)))
 337
 338 (define (handle-nondebug-protocol protocol)
 339   (case (car protocol)
 340
 341     ((eval)
 342      (set! last-lazy-trap-context #f)
 343      (apply (lambda (correlator module port-name line column code)
 344               (with-input-from-string code
 345                 (lambda ()
 346                   (set-port-filename! (current-input-port) port-name)
 347                   (set-port-line! (current-input-port) line)
 348                   (set-port-column! (current-input-port) column)
 349                   (let ((m (and module (resolve-module-from-root module))))
 350                     (catch read-error-key
 351                       (lambda ()
 352                         (let loop ((exprs '()) (x (read)))
 353                           (if (eof-object? x)
 354                               ;; Expressions to be evaluated have all
 355                               ;; been read.  Now evaluate them.
 356                               (let loop2 ((exprs (reverse! exprs))
 357                                           (results '())
 358                                           (n 1))
 359                                 (if (null? exprs)
 360                                     (write-form `(eval-results ,correlator
 361                                                                ,(if last-lazy-trap-context 't 'nil)
 362                                                                ,@results))
 363                                     (loop2 (cdr exprs)
 364                                            (append results (gds-eval (car exprs) m
 365                                                                      (if (and (null? (cdr exprs))
 366                                                                               (= n 1))
 367                                                                          #f n)))
 368                                            (+ n 1))))
 369                               ;; Another complete expression read; add
 370                               ;; it to the list.
 371                               (begin
 372                                 (for-each-breakpoint setup-after-read x)
 373                                 (loop (cons x exprs) (read))))))
 374                       (lambda (key . args)
 375                         (write-form `(eval-results
 376                                       ,correlator
 377                                       ,(if last-lazy-trap-context 't 'nil)
 378                                       ,(with-output-to-string
 379                                          (lambda ()
 380                                            (display ";;; Reading expressions")
 381                                            (display " to evaluate\n")
 382                                            (apply display-error #f
 383                                                   (current-output-port) args)))
 384                                       ("error-in-read"))))))))
 385               (if (string? port-name)
 386                   (without-traps
 387                    (lambda ()
 388                      (for-each-breakpoint setup-after-eval port-name)))))
 389             (cdr protocol)))
 390
 391     ((complete)
 392      (let ((matches (apropos-internal
 393                      (string-append "^" (regexp-quote (cadr protocol))))))
 394        (cond ((null? matches)
 395               (write-form '(completion-result nil)))
 396              (else
 397               ;;(write matches (current-error-port))
 398               ;;(newline (current-error-port))
 399               (let ((match
 400                      (let loop ((match (symbol->string (car matches)))
 401                                 (matches (cdr matches)))
 402                        ;;(write match (current-error-port))
 403                        ;;(newline (current-error-port))
 404                        ;;(write matches (current-error-port))
 405                        ;;(newline (current-error-port))
 406                        (if (null? matches)
 407                            match
 408                            (if (string-prefix=? match
 409                                                 (symbol->string (car matches)))
 410                                (loop match (cdr matches))
 411                                (loop (substring match 0
 412                                                 (- (string-length match) 1))
 413                                      matches))))))
 414                 (if (string=? match (cadr protocol))
 415                     (write-form `(completion-result
 416                                   ,(map symbol->string matches)))
 417                     (write-form `(completion-result
 418                                   ,match))))))))
 419
 420     ((debug-lazy-trap-context)
 421      (if last-lazy-trap-context
 422          (gds-debug-trap last-lazy-trap-context)
 423          (error "There is no stack available to show")))
 424
 425     ((set-breakpoint)
 426      ;; Create or update a breakpoint object according to the
 427      ;; definition.  If the target code is already loaded, note that
 428      ;; this may immediately install a trap.
 429      (let* ((num (cadr protocol))
 430             (def (caddr protocol))
 431             (behaviour (case (list-ref def 0)
 432                          ((debug) gds-debug-trap)
 433                          ((trace) gds-trace-trap)
 434                          ((trace-subtree) gds-trace-subtree)
 435                          (else (error "Unsupported behaviour:"
 436                                       (list-ref def 0)))))
 437             (bp (hash-ref breakpoints num)))
 438        (trc 'existing-bp bp)
 439        (if bp
 440            (update-breakpoint bp (list-ref def 3))
 441            (begin
 442              (set! bp
 443                    (case (list-ref def 1)
 444                      ((in)
 445                       (break-in (string->symbol (list-ref def 3))
 446                                 (list-ref def 2)
 447                                 #:behaviour behaviour))
 448                      ((at)
 449                       (break-at (list-ref def 2)
 450                                 (car (list-ref def 3))
 451                                 (cdr (list-ref def 3))
 452                                 #:behaviour behaviour))
 453                      (else
 454                       (error "Unsupported breakpoint type:"
 455                              (list-ref def 1)))))
 456              ;; Install an observer that will tell the frontend about
 457              ;; future changes in this breakpoint's status.
 458              (slot-set! bp 'observer
 459                         (lambda ()
 460                           (write-form `(breakpoint
 461                                         ,num
 462                                         ,@(map trap-description
 463                                                (slot-ref bp 'traps))))))
 464              ;; Add this to the breakpoint hash, and return the
 465              ;; breakpoint number and status to the front end.
 466              (hash-set! breakpoints num bp)))
 467        ;; Call the breakpoint's observer now.
 468        ((slot-ref bp 'observer))))
 469
 470     ((delete-breakpoint)
 471      (let* ((num (cadr protocol))
 472             (bp (hash-ref breakpoints num)))
 473        (if bp
 474            (begin
 475              (hash-remove! breakpoints num)
 476              (delete-breakpoint bp)))))
 477
 478 ;;;    ((describe-breakpoints)
 479 ;;;     ;; Describe all breakpoints.
 480 ;;;     (let ((desc
 481 ;;;         (with-output-to-string
 482 ;;;           (lambda ()
 483 ;;;             (hash-fold (lambda (num bp acc)
 484 ;;;                          (format #t
 485 ;;;                                  "Breakpoint ~a ~a (~a):\n"
 486 ;;;                                  (class-name (class-of bp))
 487 ;;;                                  num
 488 ;;;                                  (slot-ref bp 'status))
 489 ;;;                          (for-each (lambda (trap)
 490 ;;;                                      (write (trap-description trap))
 491 ;;;                                      (newline))
 492 ;;;                                    (slot-ref bp 'traps)))
 493 ;;;                        #f
 494 ;;;                        breakpoints)))))
 495 ;;;       (write-form (list 'info-result desc))))
 496
 497     (else
 498      (error "Unexpected protocol:" protocol))))
 499
 500 (define breakpoints (make-hash-table 11))
 501
 502 (define (resolve-module-from-root name)
 503   (save-module-excursion
 504    (lambda ()
 505      (set-current-module the-root-module)
 506      (resolve-module name))))
 507
 508 (define (gds-eval x m part)
 509   ;; Consumer to accept possibly multiple values and present them for
 510   ;; Emacs as a list of strings.
 511   (define (value-consumer . values)
 512     (if (unspecified? (car values))
 513         '()
 514         (map (lambda (value)
 515                (with-output-to-string (lambda () (write value))))
 516              values)))
 517   ;; Now do evaluation.
 518   (let ((intro (if part
 519                    (format #f ";;; Evaluating expression ~A" part)
 520                    ";;; Evaluating"))
 521         (value #f))
 522     (let* ((do-eval (if m
 523                         (lambda ()
 524                           (display intro)
 525                           (display " in module ")
 526                           (write (module-name m))
 527                           (newline)
 528                           (set! value
 529                                 (call-with-values (lambda ()
 530                                                     (start-stack 'gds-eval-stack
 531                                                                  (eval x m)))
 532                                   value-consumer)))
 533                         (lambda ()
 534                           (display intro)
 535                           (display " in current module ")
 536                           (write (module-name (current-module)))
 537                           (newline)
 538                           (set! value
 539                                 (call-with-values (lambda ()
 540                                                     (start-stack 'gds-eval-stack
 541                                                                  (primitive-eval x)))
 542                                   value-consumer)))))
 543            (output
 544             (with-output-to-string
 545              (lambda ()
 546                (catch #t
 547                  (lambda ()
 548                    (lazy-catch #t
 549                      do-eval
 550                      save-lazy-trap-context-and-rethrow))
 551                  (lambda (key . args)
 552                    (case key
 553                      ((misc-error signal unbound-variable numerical-overflow)
 554                       (apply display-error #f
 555                              (current-output-port) args)
 556                       (set! value '("error-in-evaluation")))
 557                      (else
 558                       (display "EXCEPTION: ")
 559                       (display key)
 560                       (display " ")
 561                       (write args)
 562                       (newline)
 563                       (set! value
 564                             '("unhandled-exception-in-evaluation"))))))))))
 565       (list output value))))
 566
 567 (define last-lazy-trap-context #f)
 568
 569 (define (save-lazy-trap-context-and-rethrow key . args)
 570   (set! last-lazy-trap-context
 571         (throw->trap-context key args save-lazy-trap-context-and-rethrow))
 572   (apply throw key args))
 573
 574 (define (run-utility)
 575   (set-gds-breakpoints)
 576   (write (getpid))
 577   (newline)
 578   (force-output)
 579   (named-module-use! '(guile-user) '(ice-9 session))
 580   (gds-accept-input #f))
 581
 582 (define (set-gds-breakpoints)
 583   (connect-to-gds)
 584   (write-form '(get-breakpoints))
 585   (gds-accept-input #t))
 586
 587 (define-method (trap-description (trap <trap>))
 588   (let loop ((description (list (class-name (class-of trap))))
 589              (next 'installed?))
 590     (case next
 591       ((installed?)
 592        (loop (if (slot-ref trap 'installed)
 593                  (cons 'installed description)
 594                  description)
 595              'conditional?))
 596       ((conditional?)
 597        (loop (if (slot-ref trap 'condition)
 598                  (cons 'conditional description)
 599                  description)
 600              'skip-count))
 601       ((skip-count)
 602        (loop (let ((skip-count (slot-ref trap 'skip-count)))
 603                (if (zero? skip-count)
 604                    description
 605                    (cons* skip-count 'skip-count description)))
 606              'single-shot?))
 607       ((single-shot?)
 608        (loop (if (slot-ref trap 'single-shot)
 609                  (cons 'single-shot description)
 610                  description)
 611              'done))
 612       (else
 613        (reverse! description)))))
 614
 615 (define-method (trap-description (trap <procedure-trap>))
 616   (let ((description (next-method)))
 617     (set-cdr! description
 618               (cons (procedure-name (slot-ref trap 'procedure))
 619                     (cdr description)))
 620     description))
 621
 622 (define-method (trap-description (trap <source-trap>))
 623   (let ((description (next-method)))
 624     (set-cdr! description
 625               (cons (format #f "~s" (slot-ref trap 'expression))
 626                     (cdr description)))
 627     description))
 628
 629 (define-method (trap-description (trap <location-trap>))
 630   (let ((description (next-method)))
 631     (set-cdr! description
 632               (cons* (slot-ref trap 'file-regexp)
 633                      (slot-ref trap 'line)
 634                      (slot-ref trap 'column)
 635                      (cdr description)))
 636     description))
 637
 638 (define (gds-trace-trap trap-context)
 639   (connect-to-gds)
 640   (gds-do-trace trap-context)
 641   (at-exit (tc:depth trap-context) gds-do-trace))
 642
 643 (define (gds-do-trace trap-context)
 644   (write-form (list 'trace
 645                     (format #f
 646                             "~3@a: ~a"
 647                             (trace/stack-real-depth trap-context)
 648                             (trace/info trap-context)))))
 649
 650 (define (gds-trace-subtree trap-context)
 651   (connect-to-gds)
 652   (gds-do-trace trap-context)
 653   (let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
 654     (install-trap step-trap)
 655     (at-exit (tc:depth trap-context)
 656              (lambda (trap-context)
 657                (uninstall-trap step-trap)))))
 658
 659 ;;; (ice-9 gds-client) ends here.