ice-9/emacs.scm

   1 ;;;;    Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
   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
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 ;;;; The author can be reached at djurfeldt@nada.kth.se
  19 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  20 ;;;; (I didn't write this!)
  21 ;;;;
  22 \f
  23
  24 ;;; *********************************************************************
  25 ;;; * This is the Guile side of the Emacs interface                     *
  26 ;;; * Experimental hACK---the real version will be coming soon (almost) *
  27 ;;; *********************************************************************
  28
  29 ;;; {Session support for Emacs}
  30 ;;;
  31
  32 (define-module (ice-9 emacs)
  33   :use-module (ice-9 debug)
  34   :use-module (ice-9 threads)
  35   :use-module (ice-9 session)
  36   :no-backtrace)
  37
  38 (define emacs-escape-character #\sub)
  39
  40 (define emacs-output-port (current-output-port))
  41
  42 (define (make-emacs-command char)
  43   (let ((cmd (list->string (list emacs-escape-character char))))
  44     (lambda ()
  45       (display cmd emacs-output-port))))
  46
  47 (define enter-input-wait  (make-emacs-command #\s))
  48 (define exit-input-wait   (make-emacs-command #\f))
  49 (define enter-read-character #\r)
  50 (define sending-error     (make-emacs-command #\F))
  51 (define sending-backtrace (make-emacs-command #\B))
  52 (define sending-result    (make-emacs-command #\x))
  53 (define end-of-text       (make-emacs-command #\.))
  54 (define no-stack          (make-emacs-command #\S))
  55 (define no-source         (make-emacs-command #\R))
  56
  57 ;; {Error handling}
  58 ;;
  59
  60 (add-hook! before-backtrace-hook sending-backtrace)
  61 (add-hook! after-backtrace-hook end-of-text)
  62 (add-hook! before-error-hook sending-error)
  63 (add-hook! after-error-hook end-of-text)
  64
  65 ;; {Repl}
  66 ;;
  67
  68 (set-current-error-port emacs-output-port)
  69
  70 (add-hook! before-read-hook
  71            (lambda ()
  72              (enter-input-wait)
  73              (force-output emacs-output-port)))
  74
  75 (add-hook! after-read-hook
  76            (lambda ()
  77              (exit-input-wait)
  78              (force-output emacs-output-port)))
  79
  80 ;;; {Misc.}
  81
  82 (define (make-emacs-load-port orig-port)
  83   (letrec ((read-char-fn  (lambda args
  84                             (let ((c (read-char orig-port)))
  85                               (if (eq? c #\soh)
  86                                   (throw 'end-of-chunk)
  87                                   c)))))
  88
  89     (make-soft-port
  90      (vector #f #f #f
  91              read-char-fn
  92              (lambda () (close-port orig-port)))
  93      "r")))
  94
  95 (set-current-input-port (make-emacs-load-port (current-input-port)))
  96
  97 (define (result-to-emacs exp)
  98   (sending-result)
  99   (write exp emacs-output-port)
 100   (end-of-text)
 101   (force-output emacs-output-port))
 102
 103 (define load-acknowledge (make-emacs-command #\l))
 104
 105 (define load-port (current-input-port))
 106
 107 (define (flush-line port)
 108   (let loop ((c (read-char port)))
 109     (if (not (eq? c #\nl))
 110         (loop (read-char port)))))
 111
 112 (define whitespace-chars (list #\space #\tab #\nl #\np))
 113
 114 (define (flush-whitespace port)
 115   (catch 'end-of-chunk
 116          (lambda ()
 117            (let loop ((c (read-char port)))
 118              (cond ((eq? c the-eof-object)
 119                     (error "End of file while recieving Emacs data"))
 120                    ((memq c whitespace-chars) (loop (read-char port)))
 121                    ((eq? c #\;) (flush-line port) (loop (read-char port)))
 122                    (else (unread-char c port))))
 123            #f)
 124          (lambda args
 125            (read-char port) ; Read final newline
 126            #t)))
 127
 128 (define (emacs-load filename linum colnum module interactivep)
 129   (set-port-filename! %%load-port filename)
 130   (set-port-line! %%load-port linum)
 131   (set-port-column! %%load-port colnum)
 132   (lazy-catch #t
 133               (lambda ()
 134                 (let loop ((endp (flush-whitespace %%load-port)))
 135                   (if (not endp)
 136                       (begin
 137                         (save-module-excursion
 138                          (lambda ()
 139                            (if module
 140                                (set-current-module (resolve-module module #f)))
 141                            (let ((result
 142                                   (start-stack read-and-eval!
 143                                                (read-and-eval! %%load-port))))
 144                              (if interactivep
 145                                  (result-to-emacs result)))))
 146                         (loop (flush-whitespace %%load-port)))
 147                       (begin
 148                         (load-acknowledge)))
 149                   (set-port-filename! %%load-port #f))) ;reset port filename
 150               (lambda (key . args)
 151                 (set-port-filename! %%load-port #f)
 152                 (cond ((eq? key 'end-of-chunk)
 153                        (fluid-set! the-last-stack #f)
 154                        (set! stack-saved? #t)
 155                        (scm-error 'misc-error
 156                                   #f
 157                                   "Incomplete expression"
 158                                   '()
 159                                   '()))
 160                       ((eq? key 'exit))
 161                       (else
 162                        (save-stack 2)
 163                        (catch 'end-of-chunk
 164                               (lambda ()
 165                                 (let loop ()
 166                                   (read-char %%load-port)
 167                                   (loop)))
 168                               (lambda args
 169                                 #f))
 170                        (apply throw key args))))))
 171
 172 (define (emacs-eval-request form)
 173   (result-to-emacs (eval form)))
 174
 175 ;;*fixme* Not necessary to use flags no-stack and no-source
 176 (define (get-frame-source frame)
 177   (if (or (not (fluid-ref the-last-stack))
 178           (>= frame (stack-length (fluid-ref the-last-stack))))
 179       (begin
 180         (no-stack)
 181         #f)
 182       (let* ((frame (stack-ref (fluid-ref the-last-stack)
 183                                (frame-number->index frame)))
 184              (source (frame-source frame)))
 185         (or source
 186             (begin (no-source)
 187                    #f)))))
 188
 189 (define (emacs-select-frame frame)
 190   (let ((source (get-frame-source frame)))
 191     (if source
 192         (let ((fname (source-property source 'filename))
 193               (line (source-property source 'line))
 194               (column (source-property source 'column)))
 195           (if (and fname line column)
 196               (list fname line column)
 197               (begin (no-source)
 198                      '())))
 199         '())))
 200
 201 (define (object->string x . method)
 202   (with-output-to-string
 203     (lambda ()
 204       ((if (null? method)
 205            write
 206            (car method))
 207        x))))
 208
 209 (define (format template . rest)
 210   (let loop ((chars (string->list template))
 211              (result '())
 212              (rest rest))
 213     (cond ((null? chars) (list->string (reverse result)))
 214           ((char=? (car chars) #\%)
 215            (loop (cddr chars)
 216                  (append (reverse
 217                           (string->list
 218                            (case (cadr chars)
 219                              ((#\S) (object->string (car rest)))
 220                              ((#\s) (object->string (car rest) display)))))
 221                          result)
 222                  (cdr rest)))
 223           (else (loop (cdr chars) (cons (car chars) result) rest)))))
 224
 225 (define (error-args->string args)
 226   (let ((msg (apply format (caddr args) (cadddr args))))
 227     (if (symbol? (cadr args))
 228         (string-append (symbol->string (cadr args))
 229                        ": "
 230                        msg)
 231         msg)))
 232
 233 (define (emacs-frame-eval frame form)
 234   (let ((source (get-frame-source frame)))
 235     (if source
 236         (catch #t
 237                (lambda ()
 238                  (list 'result
 239                        (object->string
 240                         (local-eval (with-input-from-string form read)
 241                                     (memoized-environment source)))))
 242                (lambda args
 243                  (list (car args)
 244                        (error-args->string args))))
 245         (begin
 246           (no-source)
 247           '()))))
 248
 249 (define (emacs-symdoc symbol)
 250   (if (or (not (module-bound? (current-module) symbol))
 251           (not (procedure? (eval symbol))))
 252       'nil
 253       (procedure-documentation (eval symbol))))
 254
 255 ;;; A fix to get the emacs interface to work together with the module system.
 256 ;;;
 257 (variable-set! (builtin-variable '%%load-port) load-port)
 258 (variable-set! (builtin-variable '%%emacs-load) emacs-load)
 259 (variable-set! (builtin-variable '%%emacs-eval-request) emacs-eval-request)
 260 (variable-set! (builtin-variable '%%emacs-select-frame) emacs-select-frame)
 261 (variable-set! (builtin-variable '%%emacs-frame-eval) emacs-frame-eval)
 262 (variable-set! (builtin-variable '%%emacs-symdoc) emacs-symdoc)
 263 (variable-set! (builtin-variable '%%apropos-internal) apropos-internal)