emacs/gds-client.scm

   1 ;;;; Guile Debugger UI client
   2
   3 ;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
   4 ;;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18
  19 (define-module (emacs gds-client)
  20   #:use-module (ice-9 debugger)
  21   #:use-module (ice-9 debugger behaviour)
  22   #:use-module (ice-9 debugger breakpoints)
  23   #:use-module (ice-9 debugger breakpoints procedural)
  24   #:use-module (ice-9 debugger breakpoints source)
  25   #:use-module (ice-9 debugger state)
  26   #:use-module (ice-9 debugger trap-hooks)
  27   #:use-module (ice-9 debugger utils)
  28   #:use-module (ice-9 optargs)
  29   #:use-module (ice-9 regex)
  30   #:use-module (ice-9 session)
  31   #:use-module (ice-9 string-fun)
  32   #:use-module (ice-9 threads)
  33   #:export (gds-port-number
  34             gds-connected?
  35             gds-connect
  36             gds-command-loop
  37             gds-server-died-hook)
  38   #:no-backtrace)
  39
  40
  41 ;;;; {Internal Tracing and Debugging}
  42
  43 ;; Some of this module's thread and mutex code is quite tricky and
  44 ;; includes `trc' statements to trace out useful information if the
  45 ;; environment variable GDS_TRC is defined.
  46 (define trc
  47   (if (getenv "GDS_TRC")
  48       (let ((port (open-output-file "/home/neil/gds-client.log"))
  49             (trc-mutex (make-mutex)))
  50         (lambda args
  51           (with-mutex trc-mutex
  52                       (write args port)
  53                       (newline port)
  54                       (force-output port))))
  55       noop))
  56
  57 (define-macro (assert expr)
  58   `(or ,expr
  59        (error "Assertion failed" expr)))
  60
  61
  62 ;;;; {TCP Connection}
  63
  64 ;; Communication between this module (running in the application being
  65 ;; debugged) and the GDS server and UI code (running in/under Emacs)
  66 ;; is through a TCP connection.  `gds-port-number' is the TCP port
  67 ;; number where the server listens for application connections.
  68 (define gds-port-number 8333)
  69
  70 ;; Once connected, the TCP socket port to the server.
  71 (define gds-port #f)
  72
  73 ;; Public procedure to discover whether there is a GDS connection yet.
  74 (define (gds-connected?)
  75   "Return @code{#t} if a UI server connected has been made; else @code{#f}."
  76   (not (not gds-port)))
  77
  78 ;; Public procedure to create the connection to the GDS server.
  79 (define* (gds-connect name #:optional host)
  80   "Connect to the GDS server as @var{name}, a string that should be
  81 sufficient to describe the calling application to the GDS frontend
  82 user.  The optional @var{host} arg specifies the hostname or dotted
  83 decimal IP address where the UI server is running; default is
  84 127.0.0.1."
  85   (if (gds-connected?)
  86       (error "Already connected to UI server!"))
  87   ;; Connect to debug server.
  88   (set! gds-port
  89         (let ((s (socket PF_INET SOCK_STREAM 0))
  90               (SOL_TCP 6)
  91               (TCP_NODELAY 1))
  92           (setsockopt s SOL_TCP TCP_NODELAY 1)
  93           (connect s AF_INET (inet-aton (or host "127.0.0.1")) gds-port-number)
  94           s))
  95   ;; Set debugger-output-port so that messages written to it are not
  96   ;; displayed on the application's stdout, but instead accumulated
  97   ;; for sending to the GDS frontend.
  98   (set! (debugger-output-port)
  99         (make-soft-port (vector accumulate-output
 100                                 accumulate-output
 101                                 #f #f #f #f)
 102                         "w"))
 103   ;; Announce ourselves to the server.
 104   (write-form (list 'name name (getpid)))
 105   (add-trapped-stack-id! 'gds-eval-stack)
 106   ;; Start the UI read thread.
 107   (set! ui-read-thread (make-thread ui-read-thread-proc)))
 108
 109 (define accumulated-output '())
 110
 111 (define (accumulate-output obj)
 112   (set! accumulated-output
 113         (cons (if (string? obj) obj (make-string 1 obj))
 114               accumulated-output)))
 115
 116 (define (get-accumulated-output)
 117   (let ((s (apply string-append (reverse! accumulated-output))))
 118     (set! accumulated-output '())
 119     s))
 120
 121
 122 ;;;; {UI Read Thread}
 123
 124 ;; Except when the application enters the debugger, communication with
 125 ;; the GDS server and frontend is managed by a dedicated thread for
 126 ;; this purpose.  This design avoids having to modify application code
 127 ;; at the expense of requiring a Guile with threads support.
 128 (define (ui-read-thread-proc)
 129   (write-status 'running)
 130   (let ((eval-thread-needed? #t))
 131     ;; Start up the default eval thread.
 132     (make-thread eval-thread 1 (lambda () (not eval-thread-needed?)))
 133     (with-mutex ui-read-mutex
 134       (catch 'server-died
 135         ;; Protected thunk: loop reading either protocol input from
 136         ;; the server, or an indication (through ui-read-switch-pipe)
 137         ;; that a thread in the debugger wants to take over the
 138         ;; interaction with the server.
 139         (lambda ()
 140           (let loop ((avail '()))
 141             (write-note 'startloop)
 142             (cond ((not gds-port))      ; exit loop
 143                   ((null? avail)
 144                    (write-status 'ready-for-input)
 145                    (loop (without-mutex ui-read-mutex
 146                            (car (select (list gds-port
 147                                               (car ui-read-switch-pipe))
 148                                         '() '())))))
 149                   (else
 150                    (write-note 'sthg-to-read)
 151                    (let ((port (car avail)))
 152                      (if (eq? port gds-port)
 153                          (handle-instruction #f (read gds-port))
 154                          (begin
 155                            (write-note 'debugger-takeover)
 156                            ;; Notification from debugger that it wants
 157                            ;; to take over.  Read the notification
 158                            ;; char.
 159                            (read-char (car ui-read-switch-pipe))
 160                            ;; Wait on ui-read-switch variable - this
 161                            ;; allows the debugger thread to grab the
 162                            ;; mutex.
 163                            (write-note 'cond-wait)
 164                            (signal-condition-variable ui-read-switch)
 165                            (wait-condition-variable ui-read-switch
 166                                                     ui-read-mutex)))
 167                      ;; Loop.
 168                      (loop '()))))
 169             (write-note 'loopexited)))
 170         ;; Catch handler.
 171         (lambda args #f)))
 172     ;; Tell the eval thread that it can exit.
 173     (with-mutex eval-work-mutex
 174       (set! eval-thread-needed? #f)
 175       (broadcast-condition-variable eval-work-changed))))
 176
 177 ;; It's useful to keep a note of the UI thread's id.
 178 (define ui-read-thread #f)
 179
 180 ;; Mutex used to control which thread is currently reading the TCP
 181 ;; connection to the server/UI.
 182 (define ui-read-mutex (make-mutex))
 183
 184 ;; Condition variable used by threads interested in reading the TCP
 185 ;; connection to signal changes in their state.
 186 (define ui-read-switch (make-condition-variable))
 187
 188 ;; Pipe used by application threads that enter the debugger to tell
 189 ;; the UI read thread that they'd like to take over reading the TCP
 190 ;; connection.
 191 (define ui-read-switch-pipe (pipe))
 192
 193
 194 ;;;; {Debugger Integration}
 195
 196 ;; When a thread enters the Guile debugger and a GDS connection is
 197 ;; present, the debugger calls `gds-command-loop' instead of entering
 198 ;; its usual command loop.
 199 (define (gds-command-loop state)
 200   "Interact with the UI frontend."
 201   (or (gds-connected?)
 202       (error "Not connected to UI server."))
 203   ;; Take over server/UI interaction from the normal UI read thread.
 204   (with-mutex ui-read-mutex
 205     (write-char #\x (cdr ui-read-switch-pipe))
 206     (force-output (cdr ui-read-switch-pipe))
 207     (write-note 'char-written)
 208     (wait-condition-variable ui-read-switch ui-read-mutex)
 209     ;; We now "have the com", as they say on Star Trek.
 210     (catch #t   ; Only expect here 'exit-debugger or 'server-died.
 211       (lambda ()
 212         (let loop ((state state))
 213           ;; Write accumulated debugger output.
 214           (write-form (list 'output (sans-surrounding-whitespace
 215                                      (get-accumulated-output))))
 216           ;; Write current state to the frontend.
 217           (if state (write-stack state))
 218           ;; Tell the frontend that we're waiting for input.
 219           (write-status 'waiting-for-input)
 220           ;; Read next instruction, act on it, and loop with updated
 221           ;; state.
 222           (loop (handle-instruction state (read gds-port)))))
 223       (lambda args *unspecified*))
 224     (write-note 'cond-signal)
 225     ;; Tell the UI read thread that it can take control again.
 226     (signal-condition-variable ui-read-switch)))
 227
 228
 229 ;;;; {General Output to Server/UI}
 230
 231 (define write-form
 232   (let ((protocol-mutex (make-mutex)))
 233     (lambda (form)
 234       ;; Write any form FORM to UI frontend.
 235       (with-mutex protocol-mutex
 236         (write form gds-port)
 237         (newline gds-port)
 238         (force-output gds-port)))))
 239
 240 (define (write-note note)
 241   ;; Write a note (for debugging this code) to UI frontend.
 242   (false-if-exception (write-form `(note ,note))))
 243
 244 (define (write-status status)
 245   (write-form (list 'current-module
 246                     (format #f "~S" (module-name (current-module)))))
 247   (write-form (list 'status status)))
 248
 249
 250 ;;;; {Stack Output to Server/UI}
 251
 252 (define (write-stack state)
 253   ;; Write Emacs-readable representation of current state to UI
 254   ;; frontend.
 255   (let ((frames (stack->emacs-readable (state-stack state)))
 256         (index (index->emacs-readable (state-index state)))
 257         (flags (flags->emacs-readable (state-flags state))))
 258     (if (memq 'backwards (debug-options))
 259         (write-form (list 'stack
 260                           frames
 261                           index
 262                           flags))
 263         ;; Calculate (length frames) here because `reverse!' will make
 264         ;; the original `frames' invalid.
 265         (let ((nframes (length frames)))
 266           (write-form (list 'stack
 267                             (reverse! frames)
 268                             (- nframes index 1)
 269                             flags))))))
 270
 271 (define (stack->emacs-readable stack)
 272   ;; Return Emacs-readable representation of STACK.
 273   (map (lambda (index)
 274          (frame->emacs-readable (stack-ref stack index)))
 275        (iota (min (stack-length stack)
 276                   (cadr (memq 'depth (debug-options)))))))
 277
 278 (define (frame->emacs-readable frame)
 279   ;; Return Emacs-readable representation of FRAME.
 280   (if (frame-procedure? frame)
 281       (list 'application
 282             (with-output-to-string
 283              (lambda ()
 284                (display (if (frame-real? frame) "  " "t "))
 285                (write-frame-short/application frame)))
 286             (source->emacs-readable (or (frame-source frame)
 287                                         (let ((proc (frame-procedure frame)))
 288                                           (and proc
 289                                                (procedure-source proc))))))
 290       (list 'evaluation
 291             (with-output-to-string
 292              (lambda ()
 293                (display (if (frame-real? frame) "  " "t "))
 294                (write-frame-short/expression frame)))
 295             (source->emacs-readable (frame-source frame)))))
 296
 297 (define (source->emacs-readable source)
 298   ;; Return Emacs-readable representation of the filename, line and
 299   ;; column source properties of SOURCE.
 300   (if (and source
 301            (string? (source-property source 'filename)))
 302       (list (source-property source 'filename)
 303             (source-property source 'line)
 304             (source-property source 'column))
 305       'nil))
 306
 307 (define (index->emacs-readable index)
 308   ;; Return Emacs-readable representation of INDEX (the current stack
 309   ;; index).
 310   index)
 311
 312 (define (flags->emacs-readable flags)
 313   ;; Return Emacs-readable representation of FLAGS passed to
 314   ;; debug-stack.
 315   (map (lambda (flag)
 316          (if (keyword? flag)
 317              (keyword->symbol flag)
 318              (format #f "~S" flag)))
 319        flags))
 320
 321
 322 ;;;; {Handling GDS Protocol Instructions}
 323
 324 ;; Instructions from the server/UI always come through here.  If
 325 ;; `state' is non-#f, we are in the debugger; otherwise, not.
 326 (define (handle-instruction state ins)
 327   (if (eof-object? ins)
 328       (server-died)
 329       (catch #t
 330              (lambda ()
 331                (lazy-catch #t
 332                            (lambda ()
 333                              (handle-instruction-1 state ins))
 334                            (lambda (key . args)
 335                              (set! internal-error-stack (make-stack #t))
 336                              (apply throw key args))))
 337              (lambda (key . args)
 338                (case key
 339                  ((exit-debugger)
 340                   (apply throw key args))
 341                  (else
 342                   (write-form
 343                    `(eval-results (error . "")
 344                                   "GDS Internal Error\n"
 345                                   ,(list (with-output-to-string
 346                                           (lambda ()
 347                                             (write key)
 348                                             (display ": ")
 349                                             (write args)
 350                                             (newline)
 351                                             (display-backtrace internal-error-stack
 352                                                                (current-output-port)))))))))
 353                state))))
 354
 355 (define (server-died)
 356   (get-accumulated-output)
 357   (close-port gds-port)
 358   (set! gds-port #f)
 359   (run-hook gds-server-died-hook)
 360   (throw 'server-died))
 361
 362 (define internal-error-stack #f)
 363
 364 (define gds-server-died-hook (make-hook))
 365
 366 (define (handle-instruction-1 state ins)
 367   ;; Read the newline that always follows an instruction.
 368   (read-char gds-port)
 369   ;; Handle instruction from the UI frontend, and return updated state.
 370   (case (car ins)
 371     ((query-modules)
 372      (write-form (cons 'modules (map module-name (loaded-modules))))
 373      state)
 374     ((query-module)
 375      (let ((name (cadr ins)))
 376        (write-form `(module ,name
 377                             ,(or (loaded-module-source name) "(no source file)")
 378                             ,@(sort (module-map (lambda (key value)
 379                                                   (symbol->string key))
 380                                                 (resolve-module-from-root name))
 381                                     string<?))))
 382      state)
 383     ((debugger-command)
 384      (or state (error "Not currently in debugger!"))
 385      (write-status 'running)
 386      (let ((name (cadr ins))
 387            (args (cddr ins)))
 388        (let ((proc (module-ref the-ice-9-debugger-commands-module name)))
 389          (if proc
 390              (apply proc state args)
 391              (throw 'internal-error proc name args))))
 392      state)
 393     ((set-breakpoint)
 394      (set-breakpoint! (case (cadddr ins)
 395                         ((debug-here) debug-here)
 396                         ((trace-here) trace-here)
 397                         ((trace-subtree) trace-subtree)
 398                         (else
 399                          (lambda ()
 400                            (display "Don't know `")
 401                            (display (cadddr ins))
 402                            (display "' behaviour; doing `debug-here' instead.\n")
 403                            (debug-here))))
 404                       (module-ref (resolve-module-from-root (cadr ins)) (caddr ins)))
 405      state)
 406     ((eval)
 407      (apply (lambda (correlator module port-name line column bpinfo code)
 408               (with-input-from-string code
 409                 (lambda ()
 410                   (set-port-filename! (current-input-port) port-name)
 411                   (set-port-line! (current-input-port) line)
 412                   (set-port-column! (current-input-port) column)
 413                   (let ((m (and module (resolve-module-from-root module))))
 414                     (let loop ((exprs '()) (x (read)))
 415                       (if (eof-object? x)
 416                           ;; Expressions to be evaluated have all been
 417                           ;; read.  Now hand them off to an
 418                           ;; eval-thread for the actual evaluation.
 419                           (with-mutex eval-work-mutex
 420                             (trc 'protocol-thread "evaluation work available")
 421                             (set! eval-work (cons* correlator m (reverse! exprs)))
 422                             (set! eval-work-available #t)
 423                             (broadcast-condition-variable eval-work-changed)
 424                             (wait-condition-variable eval-work-taken
 425                                                      eval-work-mutex)
 426                             (assert (not eval-work-available))
 427                             (trc 'protocol-thread "evaluation work underway"))
 428                           ;; Another complete expression read.  Set
 429                           ;; breakpoints in the read code as specified
 430                           ;; by bpinfo, and add it to the list.
 431                           (begin
 432                             (install-breakpoints x bpinfo)
 433                             (loop (cons x exprs) (read)))))))))
 434             (cdr ins))
 435      state)
 436     ((complete)
 437      (let ((matches (apropos-internal
 438                      (string-append "^" (regexp-quote (cadr ins))))))
 439        (cond ((null? matches)
 440               (write-form '(completion-result nil)))
 441              (else
 442               ;;(write matches (current-error-port))
 443               ;;(newline (current-error-port))
 444               (let ((match
 445                      (let loop ((match (symbol->string (car matches)))
 446                                 (matches (cdr matches)))
 447                        ;;(write match (current-error-port))
 448                        ;;(newline (current-error-port))
 449                        ;;(write matches (current-error-port))
 450                        ;;(newline (current-error-port))
 451                        (if (null? matches)
 452                            match
 453                            (if (string-prefix=? match
 454                                                 (symbol->string (car matches)))
 455                                (loop match (cdr matches))
 456                                (loop (substring match 0
 457                                                 (- (string-length match) 1))
 458                                      matches))))))
 459                 (if (string=? match (cadr ins))
 460                     (write-form `(completion-result
 461                                   ,(map symbol->string matches)))
 462                     (write-form `(completion-result
 463                                   ,match)))))))
 464      state)
 465     ((async-break)
 466      (let ((thread (car (delq ui-read-thread (all-threads)))))
 467        (write (cons 'target-thread thread))
 468        (newline)
 469        (write (cons 'ui-read-thread ui-read-thread))
 470        (newline)
 471        (system-async-mark (lambda ()
 472                             (debug-stack (make-stack #t 3) #:continuable))
 473                           thread))
 474      state)
 475     ((interrupt-eval)
 476      (let ((thread (hash-ref eval-thread-table (cadr ins))))
 477        (system-async-mark (lambda ()
 478                             (debug-stack (make-stack #t 3) #:continuable))
 479                           thread))
 480      state)
 481     (else state)))
 482
 483 (define the-ice-9-debugger-commands-module
 484   (resolve-module '(ice-9 debugger commands)))
 485
 486 (define (resolve-module-from-root name)
 487   (save-module-excursion
 488    (lambda ()
 489      (set-current-module the-root-module)
 490      (resolve-module name))))
 491
 492
 493 ;;;; {Module Browsing}
 494
 495 (define (loaded-module-source module-name)
 496   ;; Return the file name that (ice-9 boot-9) probably loaded the
 497   ;; named module from.  (The `probably' is because `%load-path' might
 498   ;; have changed since the module was loaded.)
 499   (let* ((reverse-name (reverse module-name))
 500          (name (symbol->string (car reverse-name)))
 501          (dir-hint-module-name (reverse (cdr reverse-name)))
 502          (dir-hint (apply string-append
 503                           (map (lambda (elt)
 504                                  (string-append (symbol->string elt) "/"))
 505                                dir-hint-module-name))))
 506     (%search-load-path (in-vicinity dir-hint name))))
 507
 508 (define (loaded-modules)
 509   ;; Return list of all loaded modules sorted by name.
 510   (sort (apropos-fold-all (lambda (module acc) (cons module acc)) '())
 511         (lambda (m1 m2)
 512           (symlist<? (module-name m1) (module-name m2)))))
 513
 514 (define (symlist<? l1 l2)
 515   ;; Return #t if symbol list L1 is alphabetically less than L2.
 516   (cond ((null? l1) #t)
 517         ((null? l2) #f)
 518         ((eq? (car l1) (car l2)) (symlist<? (cdr l1) (cdr l2)))
 519         (else (string<? (symbol->string (car l1)) (symbol->string (car l2))))))
 520
 521
 522 ;;;; {Source Breakpoint Installation}
 523
 524 (define (install-breakpoints x bpinfo)
 525   (define (install-recursive x)
 526     (if (list? x)
 527         (begin
 528           ;; Check source properties of x itself.
 529           (let* ((infokey (cons (source-property x 'line)
 530                                 (source-property x 'column)))
 531                  (bpentry (assoc infokey bpinfo)))
 532             (if bpentry
 533                 (let ((bp (set-breakpoint! debug-here x x)))
 534                   ;; FIXME: Here should transfer properties from the
 535                   ;; old breakpoint with index (cdr bpentry) to the
 536                   ;; new breakpoint.  (Or else provide an alternative
 537                   ;; to set-breakpoint! that reuses the same
 538                   ;; breakpoint.)
 539                   (write-form (list 'breakpoint-set
 540                                     (source-property x 'filename)
 541                                     (car infokey)
 542                                     (cdr infokey)
 543                                     (bp-number bp))))))
 544           ;; Check each of x's elements.
 545           (for-each install-recursive x))))
 546   (install-recursive x))
 547
 548
 549 ;;;; {Evaluation}
 550
 551 ;; Evaluation threads are unleashed by two possible triggers.  One is
 552 ;; a boolean variable, specific to each thread, that tells the thread
 553 ;; to exit when set to #t.  The other is another boolean variable, but
 554 ;; global, indicating that there is an evaluation to perform:
 555 (define eval-work-available #f)
 556
 557 ;; This variable, which is only valid when `eval-work-available' is
 558 ;; #t, holds the evaluation to perform:
 559 (define eval-work #f)
 560
 561 ;; A mutex protects against concurrent access to these variables.
 562 (define eval-work-mutex (make-mutex))
 563
 564 ;; Changes in these variables are signaled by broadcasting the
 565 ;; following condition variable.
 566 (define eval-work-changed (make-condition-variable))
 567
 568 ;; When an evaluation thread takes some work, it tells the main GDS
 569 ;; thread by signaling this condition variable.
 570 (define eval-work-taken (make-condition-variable))
 571
 572 (define-macro (without-mutex m . body)
 573   `(dynamic-wind
 574        (lambda () (unlock-mutex ,m))
 575        (lambda () (begin ,@body))
 576        (lambda () (lock-mutex ,m))))
 577
 578 (define next-thread-number
 579   (let ((count 0))
 580     (lambda ()
 581       (set! count (+ count 1))
 582       count)))
 583
 584 (define eval-thread-table (make-hash-table 3))
 585
 586 (define (eval-thread depth thread-should-exit-thunk)
 587   ;; Acquire mutex to check trigger variables.
 588   (with-mutex eval-work-mutex
 589     (let ((thread-number (next-thread-number)))
 590       ;; Add this thread to global hash, so we can correlate back to
 591       ;; this thread from the ID used by the GDS front end.
 592       (hash-set! eval-thread-table thread-number (current-thread))
 593       (trc 'eval-thread depth thread-number "entering loop")
 594       (let loop ()
 595         ;; Tell the front end this thread is ready.
 596         (write-form `(thread-status eval ,thread-number ready))
 597         (cond ((thread-should-exit-thunk)
 598                ;; Allow thread to exit.
 599                )
 600
 601               (eval-work-available
 602                ;; Take a local copy of the work, reset global
 603                ;; variables, then do the work with mutex released.
 604                (trc 'eval-thread depth thread-number "starting work")
 605                (let* ((work eval-work)
 606                       (subthread-needed? #t)
 607                       (correlator (car work)))
 608                  ;; Tell the front end this thread is busy.
 609                  (write-form `(thread-status eval ,thread-number busy ,correlator))
 610                  (set! eval-work-available #f)
 611                  (signal-condition-variable eval-work-taken)
 612                  (without-mutex eval-work-mutex
 613                    ;; Before starting evaluation, create another eval
 614                    ;; thread like this one, so that it can take over
 615                    ;; if another evaluation is requested before this
 616                    ;; one is finished.
 617                    (make-thread eval-thread (+ depth 1)
 618                                 (lambda () (not subthread-needed?)))
 619                    ;; Do the evaluation(s).
 620                    (let loop2 ((m (cadr work))
 621                                (exprs (cddr work))
 622                                (results '()))
 623                      (if (null? exprs)
 624                          (write-form `(eval-results ,correlator ,@results))
 625                          (loop2 m
 626                                 (cdr exprs)
 627                                 (append results (gds-eval (car exprs) m))))))
 628                  (trc 'eval-thread depth thread-number "work done")
 629                  ;; Tell the subthread that it should now exit.
 630                  (set! subthread-needed? #f)
 631                  (broadcast-condition-variable eval-work-changed)
 632                  ;; Loop for more work for this thread.
 633                  (loop)))
 634
 635               (else
 636                ;; Wait for something to change, then loop to check
 637                ;; trigger variables again.
 638                (trc 'eval-thread depth thread-number "wait")
 639                (wait-condition-variable eval-work-changed eval-work-mutex)
 640                (trc 'eval-thread depth thread-number "wait done")
 641                (loop))))
 642       (trc 'eval-thread depth thread-number "exiting")
 643       ;; Tell the front end this thread is ready.
 644       (write-form `(thread-status eval ,thread-number exiting)))))
 645
 646 (define (gds-eval x m)
 647   ;; Consumer to accept possibly multiple values and present them for
 648   ;; Emacs as a list of strings.
 649   (define (value-consumer . values)
 650     (if (unspecified? (car values))
 651         '()
 652         (map (lambda (value)
 653                (with-output-to-string (lambda () (write value))))
 654              values)))
 655   ;; Now do evaluation.
 656   (let ((value #f))
 657     (let* ((do-eval (if m
 658                         (lambda ()
 659                           (display "Evaluating in module ")
 660                           (write (module-name m))
 661                           (newline)
 662                           (set! value
 663                                 (call-with-values (lambda ()
 664                                                     (start-stack 'gds-eval-stack
 665                                                                  (eval x m)))
 666                                   value-consumer)))
 667                         (lambda ()
 668                           (display "Evaluating in current module ")
 669                           (write (module-name (current-module)))
 670                           (newline)
 671                           (set! value
 672                                 (call-with-values (lambda ()
 673                                                     (start-stack 'gds-eval-stack
 674                                                                  (primitive-eval x)))
 675                                   value-consumer)))))
 676            (output
 677             (with-output-to-string
 678              (lambda ()
 679                (catch #t
 680                       do-eval
 681                       (lambda (key . args)
 682                         (case key
 683                           ((misc-error signal unbound-variable
 684                             numerical-overflow)
 685                            (apply display-error #f
 686                                   (current-output-port) args)
 687                            (set! value '("error-in-evaluation")))
 688                           (else
 689                            (display "EXCEPTION: ")
 690                            (display key)
 691                            (display " ")
 692                            (write args)
 693                            (newline)
 694                            (set! value
 695                                  '("unhandled-exception-in-evaluation"))))))))))
 696       (list output value))))
 697
 698
 699 ;;; (emacs gds-client) ends here.