-;;;; Copyright (C) 1996, 1997 Mikael Djurfeldt
+;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
;;;;
-;;;; This program 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.
+;;;; 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 program is distributed in the hope that it will be useful,
+;;;; 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 General Public License for more details.
+;;;; 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 General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; 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
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;; (I didn't write this!)
;;;;
\f
-;;; *******************************
-;;; * Experimental hack *
-;;; * Shouldn't go into snapshots *
-;;; * Don't distribute! *
-;;; *******************************
+;;; *********************************************************************
+;;; * This is the Guile side of the Emacs interface *
+;;; * Experimental hACK---the real version will be coming soon (almost) *
+;;; *********************************************************************
;;; {Session support for Emacs}
;;;
(define-module (ice-9 emacs)
+ :use-module (ice-9 debug)
:use-module (ice-9 threads)
- :use-module (ice-9 nonblocking))
+ :use-module (ice-9 session)
+ :no-backtrace)
(define emacs-escape-character #\sub)
(lambda ()
(display cmd emacs-output-port))))
-(define enter-input-wait (make-emacs-command #\s))
-(define exit-input-wait (make-emacs-command #\f))
+(define enter-input-wait (make-emacs-command #\s))
+(define exit-input-wait (make-emacs-command #\f))
(define enter-read-character #\r)
-(define sending-error (make-emacs-command #\F))
+(define sending-error (make-emacs-command #\F))
(define sending-backtrace (make-emacs-command #\B))
(define sending-result (make-emacs-command #\x))
-(define end-of-text (make-emacs-command #\.))
+(define end-of-text (make-emacs-command #\.))
+(define no-stack (make-emacs-command #\S))
+(define no-source (make-emacs-command #\R))
;; {Error handling}
;;
(lambda () (close-port orig-port)))
"r")))
-(set! repl-input-port (make-emacs-load-port (current-input-port)))
-(set-current-input-port repl-input-port)
+(set-current-input-port (make-emacs-load-port (current-input-port)))
-(define (emacs-eval-request form)
- (let ((port (current-output-port)))
- (sending-result port)
- (write (eval form) port)
- (end-of-text port)
- (force-output port)))
+(define (result-to-emacs exp)
+ (sending-result)
+ (write exp emacs-output-port)
+ (end-of-text)
+ (force-output emacs-output-port))
(define load-acknowledge (make-emacs-command #\l))
(lambda ()
(let loop ((c (read-char port)))
(cond ((eq? c the-eof-object)
- (error "End of file while recieving Emacs data"))
+ (error "End of file while receiving Emacs data"))
((memq c whitespace-chars) (loop (read-char port)))
((eq? c #\;) (flush-line port) (loop (read-char port)))
(else (unread-char c port))))
(read-char port) ; Read final newline
#t)))
-(define (emacs-load filename linum)
+(define (emacs-load filename linum colnum module interactivep)
+ (define (read-and-eval! port)
+ (let ((x (read port)))
+ (if (eof-object? x)
+ (throw 'end-of-file)
+ (primitive-eval x))))
(set-port-filename! %%load-port filename)
(set-port-line! %%load-port linum)
- (set-port-column! %%load-port 0)
+ (set-port-column! %%load-port colnum)
(lazy-catch #t
(lambda ()
(let loop ((endp (flush-whitespace %%load-port)))
(if (not endp)
(begin
- (start-stack read-and-eval!
- (read-and-eval! %%load-port))
+ (save-module-excursion
+ (lambda ()
+ (if module
+ (set-current-module (resolve-module module #f)))
+ (let ((result
+ (start-stack read-and-eval!
+ (read-and-eval! %%load-port))))
+ (if interactivep
+ (result-to-emacs result)))))
(loop (flush-whitespace %%load-port)))
(begin
- (load-acknowledge))))
- )
+ (load-acknowledge)))
+ (set-port-filename! %%load-port #f))) ;reset port filename
(lambda (key . args)
+ (set-port-filename! %%load-port #f)
(cond ((eq? key 'end-of-chunk)
- (set! the-last-stack #f)
+ (fluid-set! the-last-stack #f)
(set! stack-saved? #t)
(scm-error 'misc-error
#f
#f))
(apply throw key args))))))
+(define (emacs-eval-request form)
+ (result-to-emacs (eval form (interaction-environment))))
+
+;;*fixme* Not necessary to use flags no-stack and no-source
+(define (get-frame-source frame)
+ (if (or (not (fluid-ref the-last-stack))
+ (>= frame (stack-length (fluid-ref the-last-stack))))
+ (begin
+ (no-stack)
+ #f)
+ (let* ((frame (stack-ref (fluid-ref the-last-stack)
+ (frame-number->index frame)))
+ (source (frame-source frame)))
+ (or source
+ (begin (no-source)
+ #f)))))
+
+(define (emacs-select-frame frame)
+ (let ((source (get-frame-source frame)))
+ (if source
+ (let ((fname (source-property source 'filename))
+ (line (source-property source 'line))
+ (column (source-property source 'column)))
+ (if (and fname line column)
+ (list fname line column)
+ (begin (no-source)
+ '())))
+ '())))
+
+(define (object->string x . method)
+ (with-output-to-string
+ (lambda ()
+ ((if (null? method)
+ write
+ (car method))
+ x))))
+
+(define (format template . rest)
+ (let loop ((chars (string->list template))
+ (result '())
+ (rest rest))
+ (cond ((null? chars) (list->string (reverse result)))
+ ((char=? (car chars) #\%)
+ (loop (cddr chars)
+ (append (reverse
+ (string->list
+ (case (cadr chars)
+ ((#\S) (object->string (car rest)))
+ ((#\s) (object->string (car rest) display)))))
+ result)
+ (cdr rest)))
+ (else (loop (cdr chars) (cons (car chars) result) rest)))))
+
+(define (error-args->string args)
+ (let ((msg (apply format (caddr args) (cadddr args))))
+ (if (symbol? (cadr args))
+ (string-append (symbol->string (cadr args))
+ ": "
+ msg)
+ msg)))
+
+(define (emacs-frame-eval frame form)
+ (let ((source (get-frame-source frame)))
+ (if source
+ (catch #t
+ (lambda ()
+ (list 'result
+ (object->string
+ (local-eval (with-input-from-string form read)
+ (memoized-environment source)))))
+ (lambda args
+ (list (car args)
+ (error-args->string args))))
+ (begin
+ (no-source)
+ '()))))
+
+(define (emacs-symdoc symbol)
+ (if (or (not (module-bound? (current-module) symbol))
+ (not (procedure? (eval symbol (interaction-environment)))))
+ 'nil
+ (procedure-documentation (eval symbol (interaction-environment)))))
+
;;; A fix to get the emacs interface to work together with the module system.
;;;
-(variable-set! (builtin-variable '%%load-port) load-port)
-(variable-set! (builtin-variable '%%emacs-load) emacs-load)
+(for-each (lambda (name value)
+ (module-define! the-root-module name value))
+ '(%%load-port
+ %%emacs-load
+ %%emacs-eval-request
+ %%emacs-select-frame
+ %%emacs-frame-eval
+ %%emacs-symdoc
+ %%apropos-internal)
+ (list load-port
+ emacs-load
+ emacs-eval-request
+ emacs-select-frame
+ emacs-frame-eval
+ emacs-symdoc
+ apropos-internal))
HCoop / bpt / guile.git / blobdiff