ice-9/emacs.scm

   1 ;;;;    Copyright (C) 1996, 1997, 1998, 1999, 2000 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 ;;;; 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 ;;;;
  42 ;;;; The author can be reached at djurfeldt@nada.kth.se
  43 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  44 ;;;; (I didn't write this!)
  45 ;;;;
  46 \f
  47
  48 ;;; *********************************************************************
  49 ;;; * This is the Guile side of the Emacs interface                     *
  50 ;;; * Experimental hACK---the real version will be coming soon (almost) *
  51 ;;; *********************************************************************
  52
  53 ;;; {Session support for Emacs}
  54 ;;;
  55
  56 (define-module (ice-9 emacs)
  57   :use-module (ice-9 debug)
  58   :use-module (ice-9 threads)
  59   :use-module (ice-9 session)
  60   :no-backtrace)
  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
  71 (define enter-input-wait  (make-emacs-command #\s))
  72 (define exit-input-wait   (make-emacs-command #\f))
  73 (define enter-read-character #\r)
  74 (define sending-error     (make-emacs-command #\F))
  75 (define sending-backtrace (make-emacs-command #\B))
  76 (define sending-result    (make-emacs-command #\x))
  77 (define end-of-text       (make-emacs-command #\.))
  78 (define no-stack          (make-emacs-command #\S))
  79 (define no-source         (make-emacs-command #\R))
  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
 119 (set-current-input-port (make-emacs-load-port (current-input-port)))
 120
 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
 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
 136 (define whitespace-chars (list #\space #\tab #\nl #\np))
 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)
 143                     (error "End of file while receiving Emacs data"))
 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
 152 (define (emacs-load filename linum colnum module interactivep)
 153   (set-port-filename! %%load-port filename)
 154   (set-port-line! %%load-port linum)
 155   (set-port-column! %%load-port colnum)
 156   (lazy-catch #t
 157               (lambda ()
 158                 (let loop ((endp (flush-whitespace %%load-port)))
 159                   (if (not endp)
 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)))))
 170                         (loop (flush-whitespace %%load-port)))
 171                       (begin
 172                         (load-acknowledge)))
 173                   (set-port-filename! %%load-port #f))) ;reset port filename
 174               (lambda (key . args)
 175                 (set-port-filename! %%load-port #f)
 176                 (cond ((eq? key 'end-of-chunk)
 177                        (fluid-set! the-last-stack #f)
 178                        (set! stack-saved? #t)
 179                        (scm-error 'misc-error
 180                                   #f
 181                                   "Incomplete expression"
 182                                   '()
 183                                   '()))
 184                       ((eq? key 'exit))
 185                       (else
 186                        (save-stack 2)
 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
 196 (define (emacs-eval-request form)
 197   (result-to-emacs (eval form (interaction-environment))))
 198
 199 ;;*fixme* Not necessary to use flags no-stack and no-source
 200 (define (get-frame-source frame)
 201   (if (or (not (fluid-ref the-last-stack))
 202           (>= frame (stack-length (fluid-ref the-last-stack))))
 203       (begin
 204         (no-stack)
 205         #f)
 206       (let* ((frame (stack-ref (fluid-ref the-last-stack)
 207                                (frame-number->index frame)))
 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
 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))
 235              (result '())
 236              (rest rest))
 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)))))
 245                          result)
 246                  (cdr rest)))
 247           (else (loop (cdr chars) (cons (car chars) result) rest)))))
 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
 257 (define (emacs-frame-eval frame form)
 258   (let ((source (get-frame-source frame)))
 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           '()))))
 272
 273 (define (emacs-symdoc symbol)
 274   (if (or (not (module-bound? (current-module) symbol))
 275           (not (procedure? (eval symbol (interaction-environment)))))
 276       'nil
 277       (procedure-documentation (eval symbol (interaction-environment)))))
 278
 279 ;;; A fix to get the emacs interface to work together with the module system.
 280 ;;;
 281 (variable-set! (builtin-variable '%%load-port) load-port)
 282 (variable-set! (builtin-variable '%%emacs-load) emacs-load)
 283 (variable-set! (builtin-variable '%%emacs-eval-request) emacs-eval-request)
 284 (variable-set! (builtin-variable '%%emacs-select-frame) emacs-select-frame)
 285 (variable-set! (builtin-variable '%%emacs-frame-eval) emacs-frame-eval)
 286 (variable-set! (builtin-variable '%%emacs-symdoc) emacs-symdoc)
 287 (variable-set! (builtin-variable '%%apropos-internal) apropos-internal)