home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / emacs.scm < prev    next >
Lisp/Scheme  |  2001-03-21  |  9KB  |  279 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: emacs.scm,v 14.29 2001/03/21 05:39:42 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; GNU Emacs/Scheme Interface
  24. ;;; package: (runtime emacs-interface)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. ;;;; Prompting
  29.  
  30. (define (emacs/prompt-for-command-expression port prompt level)
  31.   (transmit-modeline-string port prompt level)
  32.   (transmit-signal port #\R)
  33.   (read port))
  34.  
  35. (define (emacs/prompt-for-command-char port prompt level)
  36.   (transmit-modeline-string port prompt level)
  37.   (transmit-signal-with-argument port #\D "")
  38.   (transmit-signal port #\o)
  39.   (read-char-internal port))
  40.  
  41. (define (transmit-modeline-string port prompt level)
  42.   (transmit-signal-with-argument
  43.    port
  44.    #\p
  45.    (string-append (number->string level)
  46.           " "
  47.           (if (and (pair? prompt)
  48.                (eq? 'STANDARD (car prompt)))
  49.               (let ((entry (assoc (cdr prompt) cmdl-prompt-alist)))
  50.             (if entry
  51.                 (cadr entry)
  52.                 "[Evaluator]"))
  53.               (string-append "[Evaluator] " prompt)))))
  54.  
  55. (define cmdl-prompt-alist
  56.   '(("debug> " "[Debug]")
  57.     ("where> " "[Where]")))
  58.  
  59. (define (emacs/prompt-for-expression port prompt)
  60.   (transmit-signal-with-argument port #\i prompt)
  61.   (read port))
  62.  
  63. (define (emacs/prompt-for-confirmation port prompt)
  64.   (transmit-signal-with-argument
  65.    port
  66.    #\n
  67.    (let ((suffix " (y or n)? "))
  68.      (if (string-suffix? suffix prompt)
  69.      (string-append (string-head prompt
  70.                      (fix:- (string-length prompt)
  71.                         (string-length suffix)))
  72.             "? ")
  73.      prompt)))
  74.   (char=? #\y (read-char-internal port)))
  75.  
  76. (define (read-char-internal port)
  77.   (transmit-signal port #\s)
  78.   (let loop ()
  79.     (let ((char (input-port/read-char port)))
  80.       (if (char=? char #\newline)
  81.       (loop)
  82.       (begin
  83.         (transmit-signal port #\f)
  84.         char)))))
  85.  
  86. ;;;; Debugger Support
  87.  
  88. (define (emacs/debugger-failure port message)
  89.   (beep port)
  90.   (emacs-typeout port message))
  91.  
  92. (define (emacs/debugger-message port message)
  93.   (emacs-typeout port message))
  94.  
  95. (define (emacs/debugger-presentation port thunk)
  96.   (newline port)
  97.   (if emacs-presentation-top-justify?
  98.       (begin
  99.     (emacs-eval port "(setq xscheme-temp-1 (point))")
  100.     (thunk)
  101.     (emacs-eval
  102.      port
  103.      "(set-window-start (selected-window) xscheme-temp-1 nil)"))
  104.       (thunk)))
  105.  
  106. (define emacs-presentation-top-justify?
  107.   false)
  108.  
  109. ;;;; Interrupt Support
  110.  
  111. (define (emacs/clean-input/flush-typeahead char)
  112.   char
  113.   (let loop ()
  114.     (if (not (char=? #\NUL (input-port/read-char the-console-port)))
  115.     (loop)))
  116.   true)
  117.  
  118. (define (emacs/^G-interrupt)
  119.   (transmit-signal the-console-port #\g))
  120.  
  121. ;;;; Miscellaneous Hooks
  122.  
  123. (define (emacs/write-result port expression object hash-number)
  124.   expression
  125.   (cond ((eq? object emacs/write-result/ignore)
  126.      unspecific)
  127.     ((undefined-value? object)
  128.      (transmit-signal-with-argument port #\v ""))
  129.     (hash-number
  130.      ;; The #\P command used to do something useful, but now
  131.      ;; it just sets the Emacs variable `xscheme-prompt' to
  132.      ;; its string argument.  We use this to advantage here.
  133.      (transmit-signal-with-argument port #\P (write-to-string object))
  134.      (emacs-eval
  135.       port
  136.       "(xscheme-write-message-1 xscheme-prompt (format \";Value "
  137.       (number->string hash-number)
  138.       ": %s\" xscheme-prompt))"))
  139.     (else
  140.      (transmit-signal-with-argument port #\v (write-to-string object)))))
  141.  
  142. (define emacs/write-result/ignore
  143.   (list 'EMACS/WRITE-RESULT/IGNORE))
  144.  
  145. (define (emacs/error-decision repl condition)
  146.   repl condition
  147.   (transmit-signal the-console-port #\z)
  148.   (beep the-console-port)
  149.   (if paranoid-error-decision?
  150.       (cmdl-interrupt/abort-previous)))
  151.  
  152. (define paranoid-error-decision?
  153.   false)
  154.  
  155. (define (emacs/set-default-directory port pathname)
  156.   (transmit-signal-with-argument port #\w (->namestring pathname)))
  157.  
  158. (define (emacs/read-start port)
  159.   (transmit-signal port #\s)
  160.   (port/read-start the-console-port))
  161.  
  162. (define (emacs/read-finish port)
  163.   (port/read-finish the-console-port)
  164.   (transmit-signal port #\f))
  165.  
  166. ;;;; Protocol Encoding
  167.  
  168. ;;; GC-light operations are special because they must not cons.
  169. ;;; On an interpreted system, they will cons a little anyway.
  170.  
  171. (define (emacs/gc-start port)
  172.   (output-port/flush-output port)
  173.   (channel-write-block (port/output-channel port) "\033b" 0 2))
  174.  
  175. (define (emacs/gc-finish port)
  176.   (channel-write-block (port/output-channel port) "\033e" 0 2))
  177.  
  178. (define (transmit-signal port type)
  179.   (let ((channel (port/output-channel port))
  180.     (buffer (string #\altmode type)))
  181.     (output-port/flush-output port)
  182.     (with-absolutely-no-interrupts
  183.      (lambda ()
  184.        (channel-write-block channel buffer 0 2)))))
  185.  
  186. (define (transmit-signal-with-argument port type string)
  187.   (let ((channel (port/output-channel port))
  188.     (length (string-length string)))
  189.     (let ((buffer-length (+ length 3)))
  190.       (let ((buffer (make-string buffer-length)))
  191.     (string-set! buffer 0 #\altmode)
  192.     (string-set! buffer 1 type)
  193.     (substring-move! string 0 length buffer 2)
  194.     (string-set! buffer (- buffer-length 1) #\altmode)
  195.     (output-port/flush-output port)
  196.     (with-absolutely-no-interrupts
  197.      (lambda ()
  198.        (channel-write-block channel buffer 0 buffer-length)))))))
  199.  
  200. (define (emacs-typeout port message)
  201.   (emacs-eval port "(message \"%s\" " (write-to-string message) ")"))
  202.  
  203. (define (emacs-eval port . strings)
  204.   (transmit-signal-with-argument port #\E (apply string-append strings)))
  205.  
  206. ;;;; Initialization
  207.  
  208. (define emacs-console-port)
  209. (define console-output-channel)
  210.  
  211. (define (initialize-package!)
  212.   (set! emacs-console-port
  213.     (make-port (make-port-type
  214.             `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression)
  215.               (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char)
  216.               (PROMPT-FOR-COMMAND-EXPRESSION
  217.                ,emacs/prompt-for-command-expression)
  218.               (PROMPT-FOR-CONFIRMATION ,emacs/prompt-for-confirmation)
  219.               (DEBUGGER-FAILURE ,emacs/debugger-failure)
  220.               (DEBUGGER-MESSAGE ,emacs/debugger-message)
  221.               (DEBUGGER-PRESENTATION ,emacs/debugger-presentation)
  222.               (WRITE-RESULT ,emacs/write-result)
  223.               (SET-DEFAULT-DIRECTORY ,emacs/set-default-directory)
  224.               (READ-START ,emacs/read-start)
  225.               (READ-FINISH ,emacs/read-finish)
  226.               (GC-START ,emacs/gc-start)
  227.               (GC-FINISH ,emacs/gc-finish))
  228.             the-console-port-type)
  229.            (port/state the-console-port)))
  230.   ;; YUCCH!  Kludge to copy mutex of console port into emacs port.
  231.   (set-port/thread-mutex! emacs-console-port
  232.               (port/thread-mutex the-console-port))
  233.   (set-console-i/o-port! (select-console-port))
  234.   (add-event-receiver! event:after-restore reset-console-port!))
  235.  
  236. (define (reset-console-port!)
  237.   ;; This is a kludge.  Maybe this method shouldn't be used.
  238.   (let* ((new-port (select-console-port))
  239.      (old-port?
  240.       (lambda (port)
  241.         (and (or (eq? port the-console-port)
  242.              (eq? port emacs-console-port))
  243.          (not (eq? port new-port)))))
  244.      (replacement-port
  245.       (lambda (port)
  246.         (cond ((old-port? port) new-port)
  247.           ((and (transcriptable-port? port)
  248.             (old-port? (encapsulated-port/port port)))
  249.            (make-transcriptable-port new-port))
  250.           (else #f)))))
  251.     (if (let ((port console-i/o-port))
  252.       (or (eq? port the-console-port)
  253.           (eq? port emacs-console-port)))
  254.     (set-console-i/o-port! new-port))
  255.     (do ((pairs standard-port-accessors (cdr pairs)))
  256.     ((null? pairs))
  257.       (let ((port (replacement-port ((caar pairs)))))
  258.     (if port
  259.         ((cdar pairs) port))))
  260.     (do ((cmdl (nearest-cmdl) (cmdl/parent cmdl)))
  261.     ((not cmdl))
  262.       (let ((port (replacement-port (cmdl/port cmdl))))
  263.     (if port
  264.         (set-cmdl/port! cmdl port))))))
  265.  
  266. (define (select-console-port)
  267.   (set! console-output-channel (port/output-channel the-console-port))
  268.   (if ((ucode-primitive under-emacs? 0))
  269.       (begin
  270.     (set! hook/clean-input/flush-typeahead
  271.           emacs/clean-input/flush-typeahead)
  272.     (set! hook/^G-interrupt emacs/^G-interrupt)
  273.     (set! hook/error-decision emacs/error-decision)
  274.     emacs-console-port)
  275.       (begin
  276.     (set! hook/clean-input/flush-typeahead false)
  277.     (set! hook/^G-interrupt false)
  278.     (set! hook/error-decision false)
  279.     the-console-port)))