mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
The FSF has a new address.
This commit is contained in:
Marius Vollmer
parent
5ae1bd9109
commit
92205699d0
506 changed files with 642 additions and 4585 deletions
|
|
@ -1,38 +0,0 @@
|
|||
## Process this file with automake to produce Makefile.in.
|
||||
##
|
||||
## Copyright (C) 2003, 2004 Free Software Foundation, Inc.
|
||||
##
|
||||
## This file is part of GUILE.
|
||||
##
|
||||
## GUILE is free software; you can redistribute it and/or modify
|
||||
## it under the terms of the GNU General Public License as
|
||||
## published by the Free Software Foundation; either version 2, or
|
||||
## (at your option) any later version.
|
||||
##
|
||||
## GUILE is distributed in the hope that it will be useful, but
|
||||
## WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
## GNU General Public License for more details.
|
||||
##
|
||||
## You should have received a copy of the GNU General Public
|
||||
## License along with GUILE; see the file COPYING. If not, write
|
||||
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
|
||||
## 330, Boston, MA 02111-1307 USA
|
||||
|
||||
AUTOMAKE_OPTIONS = gnu
|
||||
|
||||
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/emacs
|
||||
subpkgdata_DATA = gds-client.scm gds-server.scm
|
||||
|
||||
lisp_LISP = gds.el
|
||||
|
||||
# Suppress byte compilation for now, but only because I haven't tested
|
||||
# it yet, so have no idea whether a byte compiled version would work.
|
||||
ELCFILES =
|
||||
|
||||
info_TEXINFOS = gds.texi
|
||||
|
||||
TEXINFO_TEX = ../doc/ref/texinfo.tex
|
||||
|
||||
TAGS_FILES = $(subpkgdata_DATA) $(lisp_LISP)
|
||||
EXTRA_DIST = $(subpkgdata_DATA) $(lisp_LISP) gds-tutorial.txt gds-problems.txt
|
||||
|
|
@ -1,726 +0,0 @@
|
|||
;;;; Guile Debugger UI client
|
||||
|
||||
;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
;; License as published by the Free Software Foundation; either
|
||||
;; version 2.1 of the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This library is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; Lesser General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU Lesser General Public
|
||||
;; License along with this library; if not, write to the Free Software
|
||||
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
(define-module (emacs gds-client)
|
||||
#:use-module (ice-9 debugger)
|
||||
#:use-module (ice-9 debugger behaviour)
|
||||
#:use-module (ice-9 debugger breakpoints)
|
||||
#:use-module (ice-9 debugger breakpoints procedural)
|
||||
#:use-module (ice-9 debugger breakpoints source)
|
||||
#:use-module (ice-9 debugger state)
|
||||
#:use-module (ice-9 debugger trap-hooks)
|
||||
#:use-module (ice-9 debugger utils)
|
||||
#:use-module (ice-9 optargs)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 session)
|
||||
#:use-module (ice-9 string-fun)
|
||||
#:use-module (ice-9 threads)
|
||||
#:export (gds-port-number
|
||||
gds-connected?
|
||||
gds-connect
|
||||
gds-command-loop
|
||||
gds-server-died-hook)
|
||||
#:no-backtrace)
|
||||
|
||||
|
||||
;;;; {Internal Tracing and Debugging}
|
||||
|
||||
;; Some of this module's thread and mutex code is quite tricky and
|
||||
;; includes `trc' statements to trace out useful information if the
|
||||
;; environment variable GDS_TRC is defined.
|
||||
(define trc
|
||||
(if (getenv "GDS_TRC")
|
||||
(let ((port (open-output-file "/home/neil/gds-client.log"))
|
||||
(trc-mutex (make-mutex)))
|
||||
(lambda args
|
||||
(with-mutex trc-mutex
|
||||
(write args port)
|
||||
(newline port)
|
||||
(force-output port))))
|
||||
noop))
|
||||
|
||||
(define-macro (assert expr)
|
||||
`(or ,expr
|
||||
(error "Assertion failed" expr)))
|
||||
|
||||
|
||||
;;;; {TCP Connection}
|
||||
|
||||
;; Communication between this module (running in the application being
|
||||
;; debugged) and the GDS server and UI code (running in/under Emacs)
|
||||
;; is through a TCP connection. `gds-port-number' is the TCP port
|
||||
;; number where the server listens for application connections.
|
||||
(define gds-port-number 8333)
|
||||
|
||||
;; Once connected, the TCP socket port to the server.
|
||||
(define gds-port #f)
|
||||
|
||||
;; Public procedure to discover whether there is a GDS connection yet.
|
||||
(define (gds-connected?)
|
||||
"Return @code{#t} if a UI server connected has been made; else @code{#f}."
|
||||
(not (not gds-port)))
|
||||
|
||||
;; Public procedure to create the connection to the GDS server.
|
||||
(define* (gds-connect name #:optional host)
|
||||
"Connect to the GDS server as @var{name}, a string that should be
|
||||
sufficient to describe the calling application to the GDS frontend
|
||||
user. The optional @var{host} arg specifies the hostname or dotted
|
||||
decimal IP address where the UI server is running; default is
|
||||
127.0.0.1."
|
||||
(if (gds-connected?)
|
||||
(error "Already connected to UI server!"))
|
||||
;; Connect to debug server.
|
||||
(set! gds-port
|
||||
(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 (or host "127.0.0.1")) gds-port-number)
|
||||
s))
|
||||
;; Set debugger-output-port so that messages written to it are not
|
||||
;; displayed on the application's stdout, but instead accumulated
|
||||
;; for sending to the GDS frontend.
|
||||
(set! (debugger-output-port)
|
||||
(make-soft-port (vector accumulate-output
|
||||
accumulate-output
|
||||
#f #f #f #f)
|
||||
"w"))
|
||||
;; Announce ourselves to the server.
|
||||
(write-form (list 'name name (getpid)))
|
||||
(add-trapped-stack-id! 'gds-eval-stack)
|
||||
;; Start the UI read thread.
|
||||
(set! ui-read-thread (make-thread ui-read-thread-proc)))
|
||||
|
||||
(define accumulated-output '())
|
||||
|
||||
(define (accumulate-output obj)
|
||||
(set! accumulated-output
|
||||
(cons (if (string? obj) obj (make-string 1 obj))
|
||||
accumulated-output)))
|
||||
|
||||
(define (get-accumulated-output)
|
||||
(let ((s (apply string-append (reverse! accumulated-output))))
|
||||
(set! accumulated-output '())
|
||||
s))
|
||||
|
||||
|
||||
;;;; {UI Read Thread}
|
||||
|
||||
;; Except when the application enters the debugger, communication with
|
||||
;; the GDS server and frontend is managed by a dedicated thread for
|
||||
;; this purpose. This design avoids having to modify application code
|
||||
;; at the expense of requiring a Guile with threads support.
|
||||
(define (ui-read-thread-proc)
|
||||
(write-status 'running)
|
||||
(let ((eval-thread-needed? #t))
|
||||
;; Start up the default eval thread.
|
||||
(make-thread eval-thread 1 (lambda () (not eval-thread-needed?)))
|
||||
(with-mutex ui-read-mutex
|
||||
(catch 'server-died
|
||||
;; Protected thunk: loop reading either protocol input from
|
||||
;; the server, or an indication (through ui-read-switch-pipe)
|
||||
;; that a thread in the debugger wants to take over the
|
||||
;; interaction with the server.
|
||||
(lambda ()
|
||||
(let loop ((avail '()))
|
||||
(write-note 'startloop)
|
||||
(cond ((not gds-port)) ; exit loop
|
||||
((null? avail)
|
||||
(write-status 'ready-for-input)
|
||||
(loop (without-mutex ui-read-mutex
|
||||
(car (select (list gds-port
|
||||
(car ui-read-switch-pipe))
|
||||
'() '())))))
|
||||
(else
|
||||
(write-note 'sthg-to-read)
|
||||
(let ((port (car avail)))
|
||||
(if (eq? port gds-port)
|
||||
(handle-instruction #f (read gds-port))
|
||||
(begin
|
||||
(write-note 'debugger-takeover)
|
||||
;; Notification from debugger that it wants
|
||||
;; to take over. Read the notification
|
||||
;; char.
|
||||
(read-char (car ui-read-switch-pipe))
|
||||
;; Wait on ui-read-switch variable - this
|
||||
;; allows the debugger thread to grab the
|
||||
;; mutex.
|
||||
(write-note 'cond-wait)
|
||||
(signal-condition-variable ui-read-switch)
|
||||
(wait-condition-variable ui-read-switch
|
||||
ui-read-mutex)))
|
||||
;; Loop.
|
||||
(loop '()))))
|
||||
(write-note 'loopexited)))
|
||||
;; Catch handler.
|
||||
(lambda args #f)))
|
||||
;; Tell the eval thread that it can exit.
|
||||
(with-mutex eval-work-mutex
|
||||
(set! eval-thread-needed? #f)
|
||||
(broadcast-condition-variable eval-work-changed))))
|
||||
|
||||
;; It's useful to keep a note of the UI thread's id.
|
||||
(define ui-read-thread #f)
|
||||
|
||||
;; Mutex used to control which thread is currently reading the TCP
|
||||
;; connection to the server/UI.
|
||||
(define ui-read-mutex (make-mutex))
|
||||
|
||||
;; Condition variable used by threads interested in reading the TCP
|
||||
;; connection to signal changes in their state.
|
||||
(define ui-read-switch (make-condition-variable))
|
||||
|
||||
;; Pipe used by application threads that enter the debugger to tell
|
||||
;; the UI read thread that they'd like to take over reading the TCP
|
||||
;; connection.
|
||||
(define ui-read-switch-pipe (pipe))
|
||||
|
||||
|
||||
;;;; {Debugger Integration}
|
||||
|
||||
;; When a thread enters the Guile debugger and a GDS connection is
|
||||
;; present, the debugger calls `gds-command-loop' instead of entering
|
||||
;; its usual command loop.
|
||||
(define (gds-command-loop state)
|
||||
"Interact with the UI frontend."
|
||||
(or (gds-connected?)
|
||||
(error "Not connected to UI server."))
|
||||
;; Take over server/UI interaction from the normal UI read thread.
|
||||
(with-mutex ui-read-mutex
|
||||
(write-char #\x (cdr ui-read-switch-pipe))
|
||||
(force-output (cdr ui-read-switch-pipe))
|
||||
(write-note 'char-written)
|
||||
(wait-condition-variable ui-read-switch ui-read-mutex)
|
||||
;; We now "have the com", as they say on Star Trek.
|
||||
(catch #t ; Only expect here 'exit-debugger or 'server-died.
|
||||
(lambda ()
|
||||
(let loop ((state state))
|
||||
;; Write accumulated debugger output.
|
||||
(write-form (list 'output (sans-surrounding-whitespace
|
||||
(get-accumulated-output))))
|
||||
;; Write current state to the frontend.
|
||||
(if state (write-stack state))
|
||||
;; Tell the frontend that we're waiting for input.
|
||||
(write-status 'waiting-for-input)
|
||||
;; Read next instruction, act on it, and loop with updated
|
||||
;; state.
|
||||
(loop (handle-instruction state (read gds-port)))))
|
||||
(lambda args *unspecified*))
|
||||
(write-note 'cond-signal)
|
||||
;; Tell the UI read thread that it can take control again.
|
||||
(signal-condition-variable ui-read-switch)))
|
||||
|
||||
|
||||
;;;; {General Output to Server/UI}
|
||||
|
||||
(define write-form
|
||||
(let ((protocol-mutex (make-mutex)))
|
||||
(lambda (form)
|
||||
;; Write any form FORM to UI frontend.
|
||||
(with-mutex protocol-mutex
|
||||
(write form gds-port)
|
||||
(newline gds-port)
|
||||
(force-output gds-port)))))
|
||||
|
||||
(define (write-note note)
|
||||
;; Write a note (for debugging this code) to UI frontend.
|
||||
(false-if-exception (write-form `(note ,note))))
|
||||
|
||||
(define (write-status status)
|
||||
(write-form (list 'current-module
|
||||
(format #f "~S" (module-name (current-module)))))
|
||||
(write-form (list 'status status)))
|
||||
|
||||
|
||||
;;;; {Stack Output to Server/UI}
|
||||
|
||||
(define (write-stack state)
|
||||
;; Write Emacs-readable representation of current state to UI
|
||||
;; frontend.
|
||||
(let ((frames (stack->emacs-readable (state-stack state)))
|
||||
(index (index->emacs-readable (state-index state)))
|
||||
(flags (flags->emacs-readable (state-flags state))))
|
||||
(if (memq 'backwards (debug-options))
|
||||
(write-form (list 'stack
|
||||
frames
|
||||
index
|
||||
flags))
|
||||
;; Calculate (length frames) here because `reverse!' will make
|
||||
;; the original `frames' invalid.
|
||||
(let ((nframes (length frames)))
|
||||
(write-form (list 'stack
|
||||
(reverse! frames)
|
||||
(- nframes index 1)
|
||||
flags))))))
|
||||
|
||||
(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 (or (frame-source frame)
|
||||
(let ((proc (frame-procedure frame)))
|
||||
(and proc
|
||||
(procedure-source proc))))))
|
||||
(list 'evaluation
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(display (if (frame-real? frame) " " "t "))
|
||||
(write-frame-short/expression frame)))
|
||||
(source->emacs-readable (frame-source frame)))))
|
||||
|
||||
(define (source->emacs-readable source)
|
||||
;; Return Emacs-readable representation of the filename, line and
|
||||
;; column source properties of SOURCE.
|
||||
(if (and source
|
||||
(string? (source-property source 'filename)))
|
||||
(list (source-property source 'filename)
|
||||
(source-property source 'line)
|
||||
(source-property source 'column))
|
||||
'nil))
|
||||
|
||||
(define (index->emacs-readable index)
|
||||
;; Return Emacs-readable representation of INDEX (the current stack
|
||||
;; index).
|
||||
index)
|
||||
|
||||
(define (flags->emacs-readable flags)
|
||||
;; Return Emacs-readable representation of FLAGS passed to
|
||||
;; debug-stack.
|
||||
(map (lambda (flag)
|
||||
(if (keyword? flag)
|
||||
(keyword->symbol flag)
|
||||
(format #f "~S" flag)))
|
||||
flags))
|
||||
|
||||
|
||||
;;;; {Handling GDS Protocol Instructions}
|
||||
|
||||
;; Instructions from the server/UI always come through here. If
|
||||
;; `state' is non-#f, we are in the debugger; otherwise, not.
|
||||
(define (handle-instruction state ins)
|
||||
(if (eof-object? ins)
|
||||
(server-died)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(lazy-catch #t
|
||||
(lambda ()
|
||||
(handle-instruction-1 state ins))
|
||||
(lambda (key . args)
|
||||
(set! internal-error-stack (make-stack #t))
|
||||
(apply throw key args))))
|
||||
(lambda (key . args)
|
||||
(case key
|
||||
((exit-debugger)
|
||||
(apply throw key args))
|
||||
(else
|
||||
(write-form
|
||||
`(eval-results (error . "")
|
||||
"GDS Internal Error\n"
|
||||
,(list (with-output-to-string
|
||||
(lambda ()
|
||||
(write key)
|
||||
(display ": ")
|
||||
(write args)
|
||||
(newline)
|
||||
(display-backtrace internal-error-stack
|
||||
(current-output-port)))))))))
|
||||
state))))
|
||||
|
||||
(define (server-died)
|
||||
(get-accumulated-output)
|
||||
(close-port gds-port)
|
||||
(set! gds-port #f)
|
||||
(run-hook gds-server-died-hook)
|
||||
(throw 'server-died))
|
||||
|
||||
(define internal-error-stack #f)
|
||||
|
||||
(define gds-server-died-hook (make-hook))
|
||||
|
||||
(define (handle-instruction-1 state ins)
|
||||
;; Read the newline that always follows an instruction.
|
||||
(read-char gds-port)
|
||||
;; Handle instruction from the UI frontend, and return updated state.
|
||||
(case (car ins)
|
||||
((query-modules)
|
||||
(write-form (cons 'modules (map module-name (loaded-modules))))
|
||||
state)
|
||||
((query-module)
|
||||
(let ((name (cadr ins)))
|
||||
(write-form `(module ,name
|
||||
,(or (loaded-module-source name) "(no source file)")
|
||||
,@(sort (module-map (lambda (key value)
|
||||
(symbol->string key))
|
||||
(resolve-module-from-root name))
|
||||
string<?))))
|
||||
state)
|
||||
((debugger-command)
|
||||
(or state (error "Not currently in debugger!"))
|
||||
(write-status 'running)
|
||||
(let ((name (cadr ins))
|
||||
(args (cddr ins)))
|
||||
(let ((proc (module-ref the-ice-9-debugger-commands-module name)))
|
||||
(if proc
|
||||
(apply proc state args)
|
||||
(throw 'internal-error proc name args))))
|
||||
state)
|
||||
((set-breakpoint)
|
||||
(set-breakpoint! (case (cadddr ins)
|
||||
((debug-here) debug-here)
|
||||
((trace-here) trace-here)
|
||||
((trace-subtree) trace-subtree)
|
||||
(else
|
||||
(lambda ()
|
||||
(display "Don't know `")
|
||||
(display (cadddr ins))
|
||||
(display "' behaviour; doing `debug-here' instead.\n")
|
||||
(debug-here))))
|
||||
(module-ref (resolve-module-from-root (cadr ins)) (caddr ins)))
|
||||
state)
|
||||
((eval)
|
||||
(apply (lambda (correlator module port-name line column bpinfo code)
|
||||
(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
|
||||
(lambda ()
|
||||
(let loop ((exprs '()) (x (read)))
|
||||
(if (eof-object? x)
|
||||
;; Expressions to be evaluated have all
|
||||
;; been read. Now hand them off to an
|
||||
;; eval-thread for the actual
|
||||
;; evaluation.
|
||||
(with-mutex eval-work-mutex
|
||||
(trc 'protocol-thread
|
||||
"evaluation work available")
|
||||
(set! eval-work
|
||||
(cons* correlator m (reverse! exprs)))
|
||||
(set! eval-work-available #t)
|
||||
(broadcast-condition-variable eval-work-changed)
|
||||
(wait-condition-variable eval-work-taken
|
||||
eval-work-mutex)
|
||||
(assert (not eval-work-available))
|
||||
(trc 'protocol-thread
|
||||
"evaluation work underway"))
|
||||
;; Another complete expression read.
|
||||
;; Set breakpoints in the read code as
|
||||
;; specified by bpinfo, and add it to
|
||||
;; the list.
|
||||
(begin
|
||||
(install-breakpoints x bpinfo)
|
||||
(loop (cons x exprs) (read))))))
|
||||
(lambda (key . args)
|
||||
(write-form `(eval-results
|
||||
,correlator
|
||||
,(with-output-to-string
|
||||
(lambda ()
|
||||
(display ";;; Reading expressions")
|
||||
(display " to evaluate\n")
|
||||
(apply display-error #f
|
||||
(current-output-port) args)))
|
||||
("error-in-read")))))))))
|
||||
(cdr ins))
|
||||
state)
|
||||
((complete)
|
||||
(let ((matches (apropos-internal
|
||||
(string-append "^" (regexp-quote (cadr ins))))))
|
||||
(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 ins))
|
||||
(write-form `(completion-result
|
||||
,(map symbol->string matches)))
|
||||
(write-form `(completion-result
|
||||
,match)))))))
|
||||
state)
|
||||
((async-break)
|
||||
(let ((thread (car (delq ui-read-thread (all-threads)))))
|
||||
(write (cons 'target-thread thread))
|
||||
(newline)
|
||||
(write (cons 'ui-read-thread ui-read-thread))
|
||||
(newline)
|
||||
(system-async-mark (lambda ()
|
||||
(debug-stack (make-stack #t 3) #:continuable))
|
||||
thread))
|
||||
state)
|
||||
((interrupt-eval)
|
||||
(let ((thread (hash-ref eval-thread-table (cadr ins))))
|
||||
(system-async-mark (lambda ()
|
||||
(debug-stack (make-stack #t 3) #:continuable))
|
||||
thread))
|
||||
state)
|
||||
(else state)))
|
||||
|
||||
(define the-ice-9-debugger-commands-module
|
||||
(resolve-module '(ice-9 debugger commands)))
|
||||
|
||||
(define (resolve-module-from-root name)
|
||||
(save-module-excursion
|
||||
(lambda ()
|
||||
(set-current-module the-root-module)
|
||||
(resolve-module name))))
|
||||
|
||||
|
||||
;;;; {Module Browsing}
|
||||
|
||||
(define (loaded-module-source module-name)
|
||||
;; Return the file name that (ice-9 boot-9) probably loaded the
|
||||
;; named module from. (The `probably' is because `%load-path' might
|
||||
;; have changed since the module was loaded.)
|
||||
(let* ((reverse-name (reverse module-name))
|
||||
(name (symbol->string (car reverse-name)))
|
||||
(dir-hint-module-name (reverse (cdr reverse-name)))
|
||||
(dir-hint (apply string-append
|
||||
(map (lambda (elt)
|
||||
(string-append (symbol->string elt) "/"))
|
||||
dir-hint-module-name))))
|
||||
(%search-load-path (in-vicinity dir-hint name))))
|
||||
|
||||
(define (loaded-modules)
|
||||
;; Return list of all loaded modules sorted by name.
|
||||
(sort (apropos-fold-all (lambda (module acc) (cons module acc)) '())
|
||||
(lambda (m1 m2)
|
||||
(symlist<? (module-name m1) (module-name m2)))))
|
||||
|
||||
(define (symlist<? l1 l2)
|
||||
;; Return #t if symbol list L1 is alphabetically less than L2.
|
||||
(cond ((null? l1) #t)
|
||||
((null? l2) #f)
|
||||
((eq? (car l1) (car l2)) (symlist<? (cdr l1) (cdr l2)))
|
||||
(else (string<? (symbol->string (car l1)) (symbol->string (car l2))))))
|
||||
|
||||
|
||||
;;;; {Source Breakpoint Installation}
|
||||
|
||||
(define (install-breakpoints x bpinfo)
|
||||
(define (install-recursive x)
|
||||
(if (and (list? x) (not (null? x)))
|
||||
(begin
|
||||
;; Check source properties of x itself.
|
||||
(let* ((infokey (cons (source-property x 'line)
|
||||
(source-property x 'column)))
|
||||
(bpentry (assoc infokey bpinfo)))
|
||||
(if bpentry
|
||||
(let ((bp (set-breakpoint! debug-here x x)))
|
||||
;; FIXME: Here should transfer properties from the
|
||||
;; old breakpoint with index (cdr bpentry) to the
|
||||
;; new breakpoint. (Or else provide an alternative
|
||||
;; to set-breakpoint! that reuses the same
|
||||
;; breakpoint.)
|
||||
(write-form (list 'breakpoint-set
|
||||
(source-property x 'filename)
|
||||
(car infokey)
|
||||
(cdr infokey)
|
||||
(bp-number bp))))))
|
||||
;; Check each of x's elements.
|
||||
(for-each install-recursive x))))
|
||||
(install-recursive x))
|
||||
|
||||
|
||||
;;;; {Evaluation}
|
||||
|
||||
;; Evaluation threads are unleashed by two possible triggers. One is
|
||||
;; a boolean variable, specific to each thread, that tells the thread
|
||||
;; to exit when set to #t. The other is another boolean variable, but
|
||||
;; global, indicating that there is an evaluation to perform:
|
||||
(define eval-work-available #f)
|
||||
|
||||
;; This variable, which is only valid when `eval-work-available' is
|
||||
;; #t, holds the evaluation to perform:
|
||||
(define eval-work #f)
|
||||
|
||||
;; A mutex protects against concurrent access to these variables.
|
||||
(define eval-work-mutex (make-mutex))
|
||||
|
||||
;; Changes in these variables are signaled by broadcasting the
|
||||
;; following condition variable.
|
||||
(define eval-work-changed (make-condition-variable))
|
||||
|
||||
;; When an evaluation thread takes some work, it tells the main GDS
|
||||
;; thread by signaling this condition variable.
|
||||
(define eval-work-taken (make-condition-variable))
|
||||
|
||||
(define-macro (without-mutex m . body)
|
||||
`(dynamic-wind
|
||||
(lambda () (unlock-mutex ,m))
|
||||
(lambda () (begin ,@body))
|
||||
(lambda () (lock-mutex ,m))))
|
||||
|
||||
(define next-thread-number
|
||||
(let ((count 0))
|
||||
(lambda ()
|
||||
(set! count (+ count 1))
|
||||
count)))
|
||||
|
||||
(define eval-thread-table (make-hash-table 3))
|
||||
|
||||
(define (eval-thread depth thread-should-exit-thunk)
|
||||
;; Acquire mutex to check trigger variables.
|
||||
(with-mutex eval-work-mutex
|
||||
(let ((thread-number (next-thread-number)))
|
||||
;; Add this thread to global hash, so we can correlate back to
|
||||
;; this thread from the ID used by the GDS front end.
|
||||
(hash-set! eval-thread-table thread-number (current-thread))
|
||||
(trc 'eval-thread depth thread-number "entering loop")
|
||||
(let loop ()
|
||||
;; Tell the front end this thread is ready.
|
||||
(write-form `(thread-status eval ,thread-number ready))
|
||||
(cond ((thread-should-exit-thunk)
|
||||
;; Allow thread to exit.
|
||||
)
|
||||
|
||||
(eval-work-available
|
||||
;; Take a local copy of the work, reset global
|
||||
;; variables, then do the work with mutex released.
|
||||
(trc 'eval-thread depth thread-number "starting work")
|
||||
(let* ((work eval-work)
|
||||
(subthread-needed? #t)
|
||||
(correlator (car work)))
|
||||
;; Tell the front end this thread is busy.
|
||||
(write-form `(thread-status eval ,thread-number busy ,correlator))
|
||||
(set! eval-work-available #f)
|
||||
(signal-condition-variable eval-work-taken)
|
||||
(without-mutex eval-work-mutex
|
||||
;; Before starting evaluation, create another eval
|
||||
;; thread like this one, so that it can take over
|
||||
;; if another evaluation is requested before this
|
||||
;; one is finished.
|
||||
(make-thread eval-thread (+ depth 1)
|
||||
(lambda () (not subthread-needed?)))
|
||||
;; Do the evaluation(s).
|
||||
(let loop2 ((m (cadr work))
|
||||
(exprs (cddr work))
|
||||
(results '())
|
||||
(n 1))
|
||||
(if (null? exprs)
|
||||
(write-form `(eval-results ,correlator ,@results))
|
||||
(loop2 m
|
||||
(cdr exprs)
|
||||
(append results (gds-eval (car exprs) m
|
||||
(if (and (null? (cdr exprs))
|
||||
(= n 1))
|
||||
#f n)))
|
||||
(+ n 1)))))
|
||||
(trc 'eval-thread depth thread-number "work done")
|
||||
;; Tell the subthread that it should now exit.
|
||||
(set! subthread-needed? #f)
|
||||
(broadcast-condition-variable eval-work-changed)
|
||||
;; Loop for more work for this thread.
|
||||
(loop)))
|
||||
|
||||
(else
|
||||
;; Wait for something to change, then loop to check
|
||||
;; trigger variables again.
|
||||
(trc 'eval-thread depth thread-number "wait")
|
||||
(wait-condition-variable eval-work-changed eval-work-mutex)
|
||||
(trc 'eval-thread depth thread-number "wait done")
|
||||
(loop))))
|
||||
(trc 'eval-thread depth thread-number "exiting")
|
||||
;; Tell the front end this thread is ready.
|
||||
(write-form `(thread-status eval ,thread-number exiting)))))
|
||||
|
||||
(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 subexpression ~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
|
||||
do-eval
|
||||
(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))))
|
||||
|
||||
|
||||
;;; (emacs gds-client) ends here.
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
;;;; Guile Debugger UI server
|
||||
|
||||
;;; Copyright (C) 2003 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
;; License as published by the Free Software Foundation; either
|
||||
;; version 2.1 of the License, or (at your option) any later version.
|
||||
;;
|
||||
;; This library is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; Lesser General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU Lesser General Public
|
||||
;; License along with this library; if not, write to the Free Software
|
||||
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
(define-module (emacs gds-server)
|
||||
#:use-module (emacs gds-client)
|
||||
#:export (run-server))
|
||||
|
||||
;; UI is normally via a pipe to Emacs, so make sure to flush output
|
||||
;; every time we write.
|
||||
(define (write-to-ui form)
|
||||
(write form)
|
||||
(newline)
|
||||
(force-output))
|
||||
|
||||
(define (trc . args)
|
||||
(write-to-ui (cons '* args)))
|
||||
|
||||
(define (with-error->eof proc port)
|
||||
(catch #t
|
||||
(lambda () (proc port))
|
||||
(lambda args the-eof-object)))
|
||||
|
||||
(define (run-server . ignored-args)
|
||||
|
||||
(let ((server (socket PF_INET SOCK_STREAM 0)))
|
||||
|
||||
;; Initialize server socket.
|
||||
(setsockopt server SOL_SOCKET SO_REUSEADDR 1)
|
||||
(bind server AF_INET INADDR_ANY gds-port-number)
|
||||
(listen server 5)
|
||||
|
||||
(let loop ((clients '()) (readable-sockets '()))
|
||||
|
||||
(define (do-read port)
|
||||
(cond ((eq? port (current-input-port))
|
||||
(do-read-from-ui))
|
||||
((eq? port server)
|
||||
(accept-new-client))
|
||||
(else
|
||||
(do-read-from-client port))))
|
||||
|
||||
(define (do-read-from-ui)
|
||||
(trc "reading from ui")
|
||||
(let* ((form (with-error->eof read (current-input-port)))
|
||||
(client (assq-ref (map (lambda (port)
|
||||
(cons (fileno port) port))
|
||||
clients)
|
||||
(car form))))
|
||||
(with-error->eof read-char (current-input-port))
|
||||
(if client
|
||||
(begin
|
||||
(write (cdr form) client)
|
||||
(newline client))
|
||||
(trc "client not found")))
|
||||
clients)
|
||||
|
||||
(define (accept-new-client)
|
||||
(cons (car (accept server)) clients))
|
||||
|
||||
(define (do-read-from-client port)
|
||||
(trc "reading from client")
|
||||
(let ((next-char (with-error->eof peek-char port)))
|
||||
;;(trc 'next-char next-char)
|
||||
(cond ((eof-object? next-char)
|
||||
(write-to-ui (list (fileno port) 'closed))
|
||||
(close port)
|
||||
(delq port clients))
|
||||
((char=? next-char #\()
|
||||
(write-to-ui (cons (fileno port) (with-error->eof read port)))
|
||||
clients)
|
||||
(else
|
||||
(with-error->eof read-char port)
|
||||
clients))))
|
||||
|
||||
;;(trc 'clients clients)
|
||||
;;(trc 'readable-sockets readable-sockets)
|
||||
|
||||
(if (null? readable-sockets)
|
||||
(loop clients (car (select (cons (current-input-port)
|
||||
(cons server clients))
|
||||
'()
|
||||
'())))
|
||||
(loop (do-read (car readable-sockets)) (cdr readable-sockets))))))
|
||||
1626
emacs/gds.el
1626
emacs/gds.el
File diff suppressed because it is too large
Load diff
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||
;;; Version: 1
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
|
|
|
|||
|
|
@ -16,8 +16,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||
;;; Version: 1
|
||||
|
|
|
|||
|
|
@ -16,8 +16,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@
|
|||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
;; Boston, MA 02111-1307, USA.
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue