ice-9/emacs.scm

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