guile18/ice-9/emacs.scm

   1 ;;;;    Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library 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 GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 ;;;; The author can be reached at djurfeldt@nada.kth.se
  18 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  19 ;;;; (I didn't write this!)
  20 ;;;;
  21 \f
  22
  23 ;;; *********************************************************************
  24 ;;; * This is the Guile side of the Emacs interface                     *
  25 ;;; * Experimental hACK---the real version will be coming soon (almost) *
  26 ;;; *********************************************************************
  27
  28 ;;; {Session support for Emacs}
  29 ;;;
  30
  31 (define-module (ice-9 emacs)
  32   :use-module (ice-9 debug)
  33   :use-module (ice-9 threads)
  34   :use-module (ice-9 session)
  35   :no-backtrace)
  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 receiving 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   (define (read-and-eval! port)
 129     (let ((x (read port)))
 130       (if (eof-object? x)
 131           (throw 'end-of-file)
 132           (primitive-eval x))))
 133   (set-port-filename! %%load-port filename)
 134   (set-port-line! %%load-port linum)
 135   (set-port-column! %%load-port colnum)
 136   (lazy-catch #t
 137               (lambda ()
 138                 (let loop ((endp (flush-whitespace %%load-port)))
 139                   (if (not endp)
 140                       (begin
 141                         (save-module-excursion
 142                          (lambda ()
 143                            (if module
 144                                (set-current-module (resolve-module module #f)))
 145                            (let ((result
 146                                   (start-stack read-and-eval!
 147                                                (read-and-eval! %%load-port))))
 148                              (if interactivep
 149                                  (result-to-emacs result)))))
 150                         (loop (flush-whitespace %%load-port)))
 151                       (begin
 152                         (load-acknowledge)))
 153                   (set-port-filename! %%load-port #f))) ;reset port filename
 154               (lambda (key . args)
 155                 (set-port-filename! %%load-port #f)
 156                 (cond ((eq? key 'end-of-chunk)
 157                        (fluid-set! the-last-stack #f)
 158                        (set! stack-saved? #t)
 159                        (scm-error 'misc-error
 160                                   #f
 161                                   "Incomplete expression"
 162                                   '()
 163                                   '()))
 164                       ((eq? key 'exit))
 165                       (else
 166                        (save-stack 2)
 167                        (catch 'end-of-chunk
 168                               (lambda ()
 169                                 (let loop ()
 170                                   (read-char %%load-port)
 171                                   (loop)))
 172                               (lambda args
 173                                 #f))
 174                        (apply throw key args))))))
 175
 176 (define (emacs-eval-request form)
 177   (result-to-emacs (eval form (interaction-environment))))
 178
 179 ;;*fixme* Not necessary to use flags no-stack and no-source
 180 (define (get-frame-source frame)
 181   (if (or (not (fluid-ref the-last-stack))
 182           (>= frame (stack-length (fluid-ref the-last-stack))))
 183       (begin
 184         (no-stack)
 185         #f)
 186       (let* ((frame (stack-ref (fluid-ref the-last-stack)
 187                                (frame-number->index frame)))
 188              (source (frame-source frame)))
 189         (or source
 190             (begin (no-source)
 191                    #f)))))
 192
 193 (define (emacs-select-frame frame)
 194   (let ((source (get-frame-source frame)))
 195     (if source
 196         (let ((fname (source-property source 'filename))
 197               (line (source-property source 'line))
 198               (column (source-property source 'column)))
 199           (if (and fname line column)
 200               (list fname line column)
 201               (begin (no-source)
 202                      '())))
 203         '())))
 204
 205 (define (object->string x . method)
 206   (with-output-to-string
 207     (lambda ()
 208       ((if (null? method)
 209            write
 210            (car method))
 211        x))))
 212
 213 (define (format template . rest)
 214   (let loop ((chars (string->list template))
 215              (result '())
 216              (rest rest))
 217     (cond ((null? chars) (list->string (reverse result)))
 218           ((char=? (car chars) #\%)
 219            (loop (cddr chars)
 220                  (append (reverse
 221                           (string->list
 222                            (case (cadr chars)
 223                              ((#\S) (object->string (car rest)))
 224                              ((#\s) (object->string (car rest) display)))))
 225                          result)
 226                  (cdr rest)))
 227           (else (loop (cdr chars) (cons (car chars) result) rest)))))
 228
 229 (define (error-args->string args)
 230   (let ((msg (apply format (caddr args) (cadddr args))))
 231     (if (symbol? (cadr args))
 232         (string-append (symbol->string (cadr args))
 233                        ": "
 234                        msg)
 235         msg)))
 236
 237 (define (emacs-frame-eval frame form)
 238   (let ((source (get-frame-source frame)))
 239     (if source
 240         (catch #t
 241                (lambda ()
 242                  (list 'result
 243                        (object->string
 244                         (local-eval (with-input-from-string form read)
 245                                     (memoized-environment source)))))
 246                (lambda args
 247                  (list (car args)
 248                        (error-args->string args))))
 249         (begin
 250           (no-source)
 251           '()))))
 252
 253 (define (emacs-symdoc symbol)
 254   (if (or (not (module-bound? (current-module) symbol))
 255           (not (procedure? (eval symbol (interaction-environment)))))
 256       'nil
 257       (procedure-documentation (eval symbol (interaction-environment)))))
 258
 259 ;;; A fix to get the emacs interface to work together with the module system.
 260 ;;;
 261 (for-each (lambda (name value)
 262             (module-define! the-root-module name value))
 263           '(%%load-port
 264             %%emacs-load
 265             %%emacs-eval-request
 266             %%emacs-select-frame
 267             %%emacs-frame-eval
 268             %%emacs-symdoc
 269             %%apropos-internal)
 270           (list load-port
 271                 emacs-load
 272                 emacs-eval-request
 273                 emacs-select-frame
 274                 emacs-frame-eval
 275                 emacs-symdoc
 276                 apropos-internal))