[bpt/guile.git] / ice-9 / emacs.scm

;;;; 	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 program 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 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
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.
;;;;
;;;; The author can be reached at djurfeldt@nada.kth.se
;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
;;;; (I didn't write this!)
;;;;
\f

;;; *********************************************************************
;;; * 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 session)
  :no-backtrace)

(define emacs-escape-character #\sub)

(define emacs-output-port (current-output-port))

(define (make-emacs-command char)
  (let ((cmd (list->string (list emacs-escape-character char))))
    (lambda ()
      (display cmd emacs-output-port))))

(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-backtrace (make-emacs-command #\B))
(define sending-result    (make-emacs-command #\x))
(define end-of-text	  (make-emacs-command #\.))
(define no-stack	  (make-emacs-command #\S))
(define no-source	  (make-emacs-command #\R))

;; {Error handling}
;;

(add-hook! before-backtrace-hook sending-backtrace)
(add-hook! after-backtrace-hook end-of-text)
(add-hook! before-error-hook sending-error)
(add-hook! after-error-hook end-of-text)

;; {Repl}
;;

(set-current-error-port emacs-output-port)

(add-hook! before-read-hook
	   (lambda ()
	     (enter-input-wait)
	     (force-output emacs-output-port)))

(add-hook! after-read-hook
	   (lambda ()
	     (exit-input-wait)
	     (force-output emacs-output-port)))

;;; {Misc.}

(define (make-emacs-load-port orig-port)
  (letrec ((read-char-fn  (lambda args
			    (let ((c (read-char orig-port)))
			      (if (eq? c #\soh)
				  (throw 'end-of-chunk)
				  c)))))
    
    (make-soft-port
     (vector #f #f #f
	     read-char-fn
	     (lambda () (close-port orig-port)))
     "r")))

(set-current-input-port (make-emacs-load-port (current-input-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))

(define load-port (current-input-port))

(define (flush-line port)
  (let loop ((c (read-char port)))
    (if (not (eq? c #\nl))
	(loop (read-char port)))))

(define whitespace-chars (list #\space #\tab #\nl #\np))

(define (flush-whitespace port)
  (catch 'end-of-chunk
	 (lambda ()
	   (let loop ((c (read-char port)))
	     (cond ((eq? c the-eof-object)
		    (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))))
	   #f)
	 (lambda args
	   (read-char port) ; Read final newline
	   #t)))

(define (emacs-load filename linum colnum module interactivep)
  (set-port-filename! %%load-port filename)
  (set-port-line! %%load-port linum)
  (set-port-column! %%load-port colnum)
  (lazy-catch #t
	      (lambda ()
		(let loop ((endp (flush-whitespace %%load-port)))
		  (if (not endp)
		      (begin
			(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)))
		  (set-port-filename! %%load-port #f)))	;reset port filename
	      (lambda (key . args)
		(set-port-filename! %%load-port #f)
		(cond ((eq? key 'end-of-chunk)
		       (fluid-set! the-last-stack #f)
		       (set! stack-saved? #t)
		       (scm-error 'misc-error
				  #f
				  "Incomplete expression"
				  '()
				  '()))
		      ((eq? key 'exit))
		      (else
		       (save-stack 2)
		       (catch 'end-of-chunk
			      (lambda ()
				(let loop ()
				  (read-char %%load-port)
				  (loop)))
			      (lambda args
				#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.
;;;
(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))
Commit	Line	Data
c81f296a	1	;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
7dd98e0b MD	2	;;;;
	3	;;;; This program is free software; you can redistribute it and/or modify
	4	;;;; it under the terms of the GNU General Public License as published by
	5	;;;; the Free Software Foundation; either version 2, or (at your option)
	6	;;;; any later version.
	7	;;;;
	8	;;;; This program is distributed in the hope that it will be useful,
	9	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	;;;; GNU General Public License for more details.
	12	;;;;
	13	;;;; You should have received a copy of the GNU General Public License
	14	;;;; along with this software; see the file COPYING. If not, write to
15328041 JB	15	;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
15328041 JB	16	;;;; Boston, MA 02111-1307 USA
7dd98e0b	17	;;;;
a482f2cc MV	18	;;;; As a special exception, the Free Software Foundation gives permission
	19	;;;; for additional uses of the text contained in its release of GUILE.
	20	;;;;
	21	;;;; The exception is that, if you link the GUILE library with other files
	22	;;;; to produce an executable, this does not by itself cause the
	23	;;;; resulting executable to be covered by the GNU General Public License.
	24	;;;; Your use of that executable is in no way restricted on account of
	25	;;;; linking the GUILE library code into it.
	26	;;;;
	27	;;;; This exception does not however invalidate any other reasons why
	28	;;;; the executable file might be covered by the GNU General Public License.
	29	;;;;
	30	;;;; This exception applies only to the code released by the
	31	;;;; Free Software Foundation under the name GUILE. If you copy
	32	;;;; code from other Free Software Foundation releases into a copy of
	33	;;;; GUILE, as the General Public License permits, the exception does
	34	;;;; not apply to the code that you add in this way. To avoid misleading
	35	;;;; anyone as to the status of such modified files, you must delete
	36	;;;; this exception notice from them.
	37	;;;;
	38	;;;; If you write modifications of your own for GUILE, it is your choice
	39	;;;; whether to permit this exception to apply to your modifications.
	40	;;;; If you do not wish that, delete this exception notice.
	41	;;;;
7dd98e0b MD	42	;;;; The author can be reached at djurfeldt@nada.kth.se
7dd98e0b MD	43	;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
67da6c57	44	;;;; (I didn't write this!)
7dd98e0b MD	45	;;;;
	46	\f
	47
67da6c57 MD	48	;;; *********************************************************************
	49	;;; * This is the Guile side of the Emacs interface *
	50	;;; * Experimental hACK---the real version will be coming soon (almost) *
	51	;;; *********************************************************************
7dd98e0b MD	52
	53	;;; {Session support for Emacs}
	54	;;;
	55
	56	(define-module (ice-9 emacs)
1c215029	57	:use-module (ice-9 debug)
7dd98e0b	58	:use-module (ice-9 threads)
3267d4a1 MD	59	:use-module (ice-9 session)
3267d4a1 MD	60	:no-backtrace)
7dd98e0b MD	61
	62	(define emacs-escape-character #\sub)
	63
	64	(define emacs-output-port (current-output-port))
	65
	66	(define (make-emacs-command char)
	67	(let ((cmd (list->string (list emacs-escape-character char))))
	68	(lambda ()
	69	(display cmd emacs-output-port))))
	70
1c215029 MD	71	(define enter-input-wait (make-emacs-command #\s))
1c215029 MD	72	(define exit-input-wait (make-emacs-command #\f))
7dd98e0b	73	(define enter-read-character #\r)
1c215029	74	(define sending-error (make-emacs-command #\F))
7dd98e0b MD	75	(define sending-backtrace (make-emacs-command #\B))
7dd98e0b MD	76	(define sending-result (make-emacs-command #\x))
1c215029 MD	77	(define end-of-text (make-emacs-command #\.))
	78	(define no-stack (make-emacs-command #\S))
	79	(define no-source (make-emacs-command #\R))
7dd98e0b MD	80
	81	;; {Error handling}
	82	;;
	83
	84	(add-hook! before-backtrace-hook sending-backtrace)
	85	(add-hook! after-backtrace-hook end-of-text)
	86	(add-hook! before-error-hook sending-error)
	87	(add-hook! after-error-hook end-of-text)
	88
	89	;; {Repl}
	90	;;
	91
	92	(set-current-error-port emacs-output-port)
	93
	94	(add-hook! before-read-hook
	95	(lambda ()
	96	(enter-input-wait)
	97	(force-output emacs-output-port)))
	98
	99	(add-hook! after-read-hook
	100	(lambda ()
	101	(exit-input-wait)
	102	(force-output emacs-output-port)))
	103
	104	;;; {Misc.}
	105
	106	(define (make-emacs-load-port orig-port)
	107	(letrec ((read-char-fn (lambda args
	108	(let ((c (read-char orig-port)))
	109	(if (eq? c #\soh)
	110	(throw 'end-of-chunk)
	111	c)))))
	112
	113	(make-soft-port
	114	(vector #f #f #f
	115	read-char-fn
	116	(lambda () (close-port orig-port)))
	117	"r")))
	118
3ede541d	119	(set-current-input-port (make-emacs-load-port (current-input-port)))
7dd98e0b	120
8c5a8bed MD	121	(define (result-to-emacs exp)
	122	(sending-result)
	123	(write exp emacs-output-port)
	124	(end-of-text)
	125	(force-output emacs-output-port))
	126
7dd98e0b MD	127	(define load-acknowledge (make-emacs-command #\l))
	128
	129	(define load-port (current-input-port))
	130
	131	(define (flush-line port)
	132	(let loop ((c (read-char port)))
	133	(if (not (eq? c #\nl))
	134	(loop (read-char port)))))
	135
8c3420ad	136	(define whitespace-chars (list #\space #\tab #\nl #\np))
7dd98e0b MD	137
	138	(define (flush-whitespace port)
	139	(catch 'end-of-chunk
	140	(lambda ()
	141	(let loop ((c (read-char port)))
	142	(cond ((eq? c the-eof-object)
40fa5c3f	143	(error "End of file while receiving Emacs data"))
7dd98e0b MD	144	((memq c whitespace-chars) (loop (read-char port)))
	145	((eq? c #\;) (flush-line port) (loop (read-char port)))
	146	(else (unread-char c port))))
	147	#f)
	148	(lambda args
	149	(read-char port) ; Read final newline
	150	#t)))
	151
d43f8c97	152	(define (emacs-load filename linum colnum module interactivep)
7dd98e0b	153	(set-port-filename! %%load-port filename)
db75135d	154	(set-port-line! %%load-port linum)
1c215029	155	(set-port-column! %%load-port colnum)
7dd98e0b MD	156	(lazy-catch #t
	157	(lambda ()
	158	(let loop ((endp (flush-whitespace %%load-port)))
	159	(if (not endp)
ef0d04e5 MD	160	(begin
	161	(save-module-excursion
	162	(lambda ()
	163	(if module
	164	(set-current-module (resolve-module module #f)))
	165	(let ((result
	166	(start-stack read-and-eval!
	167	(read-and-eval! %%load-port))))
	168	(if interactivep
	169	(result-to-emacs result)))))
7dd98e0b MD	170	(loop (flush-whitespace %%load-port)))
7dd98e0b MD	171	(begin
31264e81 MD	172	(load-acknowledge)))
31264e81 MD	173	(set-port-filename! %%load-port #f))) ;reset port filename
7dd98e0b	174	(lambda (key . args)
31264e81	175	(set-port-filename! %%load-port #f)
7dd98e0b	176	(cond ((eq? key 'end-of-chunk)
a66c53a8	177	(fluid-set! the-last-stack #f)
7dd98e0b MD	178	(set! stack-saved? #t)
7dd98e0b MD	179	(scm-error 'misc-error
8c3420ad	180	#f
7dd98e0b MD	181	"Incomplete expression"
	182	'()
	183	'()))
	184	((eq? key 'exit))
	185	(else
eb7ec1e8	186	(save-stack 2)
7dd98e0b MD	187	(catch 'end-of-chunk
	188	(lambda ()
	189	(let loop ()
	190	(read-char %%load-port)
	191	(loop)))
	192	(lambda args
	193	#f))
	194	(apply throw key args))))))
	195
1c215029	196	(define (emacs-eval-request form)
a71aca7a	197	(result-to-emacs (eval form (interaction-environment))))
1c215029	198
52f1b046	199	;;fixme Not necessary to use flags no-stack and no-source
1c215029	200	(define (get-frame-source frame)
a66c53a8 MD	201	(if (or (not (fluid-ref the-last-stack))
a66c53a8 MD	202	(>= frame (stack-length (fluid-ref the-last-stack))))
1c215029 MD	203	(begin
	204	(no-stack)
	205	#f)
a66c53a8 MD	206	(let* ((frame (stack-ref (fluid-ref the-last-stack)
a66c53a8 MD	207	(frame-number->index frame)))
1c215029 MD	208	(source (frame-source frame)))
	209	(or source
	210	(begin (no-source)
	211	#f)))))
	212
	213	(define (emacs-select-frame frame)
	214	(let ((source (get-frame-source frame)))
	215	(if source
	216	(let ((fname (source-property source 'filename))
	217	(line (source-property source 'line))
	218	(column (source-property source 'column)))
	219	(if (and fname line column)
	220	(list fname line column)
	221	(begin (no-source)
	222	'())))
	223	'())))
	224
52f1b046 MD	225	(define (object->string x . method)
	226	(with-output-to-string
	227	(lambda ()
	228	((if (null? method)
	229	write
	230	(car method))
	231	x))))
	232
	233	(define (format template . rest)
	234	(let loop ((chars (string->list template))
0b6925fe MD	235	(result '())
0b6925fe MD	236	(rest rest))
52f1b046 MD	237	(cond ((null? chars) (list->string (reverse result)))
	238	((char=? (car chars) #\%)
	239	(loop (cddr chars)
	240	(append (reverse
	241	(string->list
	242	(case (cadr chars)
	243	((#\S) (object->string (car rest)))
	244	((#\s) (object->string (car rest) display)))))
0b6925fe MD	245	result)
	246	(cdr rest)))
	247	(else (loop (cdr chars) (cons (car chars) result) rest)))))
52f1b046 MD	248
	249	(define (error-args->string args)
	250	(let ((msg (apply format (caddr args) (cadddr args))))
	251	(if (symbol? (cadr args))
	252	(string-append (symbol->string (cadr args))
	253	": "
	254	msg)
	255	msg)))
	256
1c215029 MD	257	(define (emacs-frame-eval frame form)
1c215029 MD	258	(let ((source (get-frame-source frame)))
52f1b046 MD	259	(if source
	260	(catch #t
	261	(lambda ()
	262	(list 'result
	263	(object->string
	264	(local-eval (with-input-from-string form read)
	265	(memoized-environment source)))))
	266	(lambda args
	267	(list (car args)
	268	(error-args->string args))))
	269	(begin
	270	(no-source)
	271	'()))))
1c215029 MD	272
	273	(define (emacs-symdoc symbol)
	274	(if (or (not (module-bound? (current-module) symbol))
544468de	275	(not (procedure? (eval symbol (interaction-environment)))))
1c215029	276	'nil
a71aca7a	277	(procedure-documentation (eval symbol (interaction-environment)))))
1c215029	278
7dd98e0b MD	279	;;; A fix to get the emacs interface to work together with the module system.
7dd98e0b MD	280	;;;
c81f296a MD	281	(for-each (lambda (name value)
	282	(module-define! the-root-module name value))
	283	'(%%load-port
	284	%%emacs-load
	285	%%emacs-eval-request
	286	%%emacs-select-frame
	287	%%emacs-frame-eval
	288	%%emacs-symdoc
	289	%%apropos-internal)
	290	(list load-port
	291	emacs-load
	292	emacs-eval-request
	293	emacs-select-frame
	294	emacs-frame-eval
	295	emacs-symdoc
	296	apropos-internal))