/[guile]/guile/guile-core/emacs/gds-client.scm
ViewVC logotype

Diff of /guile/guile-core/emacs/gds-client.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ossau, Tue Nov 11 23:30:05 2003 UTC revision 1.2 by ossau, Wed Nov 19 01:27:31 2003 UTC
# Line 67  decimal IP address where the UI server i Line 67  decimal IP address where the UI server i
67                          "w"))                          "w"))
68    ;; Write initial context to debug server.    ;; Write initial context to debug server.
69    (write-form (list 'name name (getpid)))    (write-form (list 'name name (getpid)))
70    (write-form (cons 'modules (map module-name (loaded-modules))))    ;(write-form (cons 'modules (map module-name (loaded-modules))))
71    ;; Start the asynchronous UI thread.    ;; Start the asynchronous UI thread.
72    (start-async-gds-thread)    (start-async-gds-thread)
73    ;; If `debug' is true, debug immediately.    ;; If `debug' is true, debug immediately.
# Line 87  decimal IP address where the UI server i Line 87  decimal IP address where the UI server i
87      ;; Start the asynchronous UI thread.      ;; Start the asynchronous UI thread.
88      (begin-thread      (begin-thread
89        (set! async-gds-thread (current-thread))        (set! async-gds-thread (current-thread))
       (lock-mutex mutex)  
90        ;;(write (cons admin gds-port))        ;;(write (cons admin gds-port))
91        ;;(newline)        ;;(newline)
92          (lock-mutex mutex)
93        (catch 'server-died        (catch 'server-died
94               (lambda ()               (lambda ()
95                 (let loop ((avail '()))                 (let loop ((avail '()))
96                     (write-note 'startloop)
97                   ;;(write avail)                   ;;(write avail)
98                   ;;(newline)                   ;;(newline)
99                   (cond ((not gds-port)) ; exit loop                   (cond ((not gds-port)) ; exit loop
100                         ((null? avail)                         ((null? avail)
101                          (write-status 'ready-for-input)                          (write-status 'ready-for-input)
102                          (loop (car (select (list gds-port (car admin))                          (unlock-mutex mutex)
103                                            '() '()))))                          (let ((ports (car (select (list gds-port (car admin))
104                                                      '() '()))))
105                              (lock-mutex mutex)
106                              (loop ports)))
107                         (else                         (else
108                            (write-note 'sthg-to-read)
109                          (let ((port (car avail)))                          (let ((port (car avail)))
110                            (if (eq? port gds-port)                            (if (eq? port gds-port)
111                                (handle-instruction #f (read gds-port))                                (handle-instruction #f (read gds-port))
112                                (begin                                (begin
113                                    (write-note 'debugger-takeover)
114                                  ;; Notification from debugger that it                                  ;; Notification from debugger that it
115                                  ;; wants to take over.  Read the                                  ;; wants to take over.  Read the
116                                  ;; notification char.                                  ;; notification char.
117                                  (read-char (car admin))                                  (read-char (car admin))
118                                  ;; Wait on condition variable - this allows the                                  ;; Wait on condition variable - this allows the
119                                  ;; debugger thread to grab the mutex.                                  ;; debugger thread to grab the mutex.
120                                  (wait-condition-variable condition mutex)))                                  (write-note 'cond-wait)
121                                    (signal-condition-variable condition)
122                                    (wait-condition-variable condition mutex)
123                                    ))
124                            ;; Loop.                            ;; Loop.
125                            (loop (cdr avail)))))))                            (loop '()))))
126                     (write-note 'loopexited)))
127               (lambda args #f))               (lambda args #f))
128        (set! gds-disable-async-thread noop)        (set! gds-disable-async-thread noop)
129        (set! gds-continue-async-thread noop)        (set! gds-continue-async-thread noop)
# Line 122  decimal IP address where the UI server i Line 132  decimal IP address where the UI server i
132      ;; Redefine procs used by debugger thread to take control.      ;; Redefine procs used by debugger thread to take control.
133      (set! gds-disable-async-thread      (set! gds-disable-async-thread
134            (lambda ()            (lambda ()
135                (lock-mutex mutex)
136              (write-char #\x (cdr admin))              (write-char #\x (cdr admin))
137              (force-output (cdr admin))              (force-output (cdr admin))
138                (write-note 'char-written)
139                (wait-condition-variable condition mutex)
140              ;;(display "gds-disable-async-thread: locking mutex...\n"              ;;(display "gds-disable-async-thread: locking mutex...\n"
141              ;;       (current-error-port))              ;;       (current-error-port))
142              (lock-mutex mutex)))              ))
143      (set! gds-continue-async-thread      (set! gds-continue-async-thread
144            (lambda ()            (lambda ()
145              (unlock-mutex mutex)              (write-note 'cond-signal)
146              (signal-condition-variable condition)))))              (signal-condition-variable condition)
147                ;; Make sure that the async thread has got the message
148                ;; before we could possibly try to grab the main mutex
149                ;; again.
150                (unlock-mutex mutex)))))
151    
152  (define accumulated-output '())  (define accumulated-output '())
153    
# Line 195  decimal IP address where the UI server i Line 212  decimal IP address where the UI server i
212    (newline gds-port)    (newline gds-port)
213    (force-output gds-port))    (force-output gds-port))
214    
215    (define (write-note note)
216      ;; Write a note (for debugging this code) to UI frontend.
217      (false-if-exception (write-form `(note ,note))))
218    
219  (define (stack->emacs-readable stack)  (define (stack->emacs-readable stack)
220    ;; Return Emacs-readable representation of STACK.    ;; Return Emacs-readable representation of STACK.
221    (map (lambda (index)    (map (lambda (index)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26