home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / ETOPLEVE.S < prev    next >
Encoding:
Text File  |  1993-08-21  |  7.3 KB  |  233 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;    Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;; toplevel
  43.  
  44. (define edwin-editor)
  45. (define *pcs-contents* '())
  46.  
  47. (define edwin
  48.   (letrec
  49.    ((%edwin-reset
  50.      (lambda ()
  51.        (set! edwin-editor (make-editor "Edwin"))
  52.        (reset-display)
  53.        *the-non-printing-object*))
  54.  
  55.     (reset-display
  56.      (lambda ()
  57.        (reset-buffer-window (current-buffer-window))
  58.        (reset-modeline-window)
  59.        (reset-typein-window))))
  60.  
  61.    (lambda ()
  62.      (let
  63.        ((ge (%set-global-environment edwin-environment)))
  64.          (if (not *split-screen-mode?*)
  65.          (set! edwin-maxlines (1+ (car (window-get-size 'console)))))
  66.          (%set-global-environment ge))
  67.      (call/cc
  68.        (lambda (k)
  69.      (fluid-let ((editor-continuation k))
  70.        (save-console-contents)
  71.        (make-pcs-status-invisible)
  72.        (if (or (unassigned? edwin-editor)
  73.            (not edwin-editor))
  74.            (%edwin-reset)
  75.            (reset-display))
  76.        (top-level-command-reader)))))))
  77.  
  78. (define top-level-command-reader
  79.   (lambda ()
  80.     (letrec
  81.       ((top-level-command-reader
  82.      (lambda ()
  83.        (catch
  84.         (lambda (k)
  85.           (fluid-let ((*error-continuation* k)
  86.               (*^G-continuation* k))
  87.         (command-reader))))
  88.        (top-level-command-reader)))
  89.  
  90.        (command-reader
  91.      (lambda ()
  92.        (fluid-let ((*command-message* #F))
  93.          (with-command-argument-reader
  94.           (lambda ()
  95.         (command-reader-loop))))))
  96.  
  97.        (command-reader-loop
  98.      (lambda ()
  99.        (fluid-let ((*command-char* '())
  100.                (*command* '())
  101.                (*next-message* #F))
  102.          (start-next-command)
  103.          (set-fluid! *command-message* (fluid *next-message*)))
  104.        (command-reader-loop )))
  105.  
  106.        (start-next-command
  107.      (lambda ()
  108.        (reset-command-argument-reader!)
  109.        (reset-command-prompt!)
  110.        (read-and-dispatch-on-char))))
  111.       (top-level-command-reader))))
  112.  
  113. (define (throw continuation value)
  114.   (continuation value))
  115.  
  116. (define (abort-current-command)
  117.   (throw (error-continuation) 'abort))
  118.  
  119. (define (error-continuation)
  120.   (fluid *error-continuation*))
  121.  
  122. (define (editor-error . msg)
  123.   (beep)
  124.   (if msg (temporary-message (car msg)))
  125.   (abort-current-command))
  126.  
  127. (define (read-and-dispatch-on-char)
  128.   (dispatch-on-char (editor-read-char (window-screen (current-window)))))
  129.  
  130. (define ^G-char (integer->char 7))
  131.  
  132. (define editor-read-char
  133.   (lambda (screen)
  134.     (if (not (char-ready? screen))
  135.     (begin
  136.       (update-display! (current-window))
  137.       (update-modeline!)))
  138.     (if (not (eq? screen typein-screen))
  139.     (if (or (not (char-ready?))
  140.         (delay-input 50 screen))
  141.         (update-typein-window!)))
  142.     (let ((char (read-char screen)))
  143.      (cond ((eq? char ^G-char) (editor-error "Abort"))
  144.            ((eof-object? char) ^Z-char)
  145.            (else char)))))
  146.  
  147. (define (dispatch-on-char char)
  148.    (set-fluid! *command-char* char)
  149.    (set-command-prompt!
  150.     (string-append-separated (command-argument-prompt)
  151.                  (obj->string char)))
  152.   (dispatch-on-command (comtab-entry char) char))
  153.  
  154. (define (dispatch-on-command command char)
  155.   (set-fluid! *command* command)
  156.   (let ((procedure command)
  157.     (argument
  158.      (or (command-argument-value)
  159.          (and (command-argument-negative?) -1))))
  160.     (if (or argument)
  161.         ;; The C-U for numeric arguments has already reset the paren cache,
  162.         ;; so no need to do anything further about it here.
  163.         (procedure argument)
  164.         ;; Reset the paren-cache on any non-insert or left-paren command.
  165.         ;; Be careful we *don't* reset it on right-paren.
  166.     (cond ((eq? procedure ^r-insert-self-command)
  167.                (and (char=? #\( char) (cache-paren-mark '()))   ;;;;;)  3.02
  168.            (let ((window (current-window))
  169.              (point (current-point)))
  170.          (if (and (buffer-modified? (window-buffer window))
  171.               (line-end? point)
  172.               (char-graphic? char)
  173.               (< (window-point-x window)
  174.                  (-1+ (window-x-size window))))
  175.              (begin (%region-insert-char! (mark-line point)
  176.                           (mark-position point)
  177.                           char)
  178.                 (direct-output-for-insert! window
  179.                                char))
  180.              (region-insert-char! point char))))
  181.           ((eq? procedure ^r-forward-character-command)
  182.                (cache-paren-mark '())                ;3.02
  183.            (let ((window (current-window))
  184.              (point (current-point)))
  185.          (if (and (not (group-end? point))
  186.               (char-graphic? (mark-right-char point))
  187.               (< (window-point-x window)
  188.                  (- 2 (window-x-size window))))
  189.                  ;;; to take care of continuation lines
  190.              (direct-output-forward-character! window)
  191.              (procedure argument))))
  192.           ((eq? procedure ^r-backward-character-command)
  193.                (cache-paren-mark '())                ;3.02
  194.            (let ((window (current-window))
  195.              (point (current-point)))
  196.          (if (and (not (group-start? point))
  197.               (char-graphic? (mark-left-char point))
  198.               ;; Use 1 instead of 0 so we don't have
  199.               ;; to worry about continuation lines.
  200.               (> (window-point-x window) 1))
  201.              (direct-output-backward-character! window)
  202.              (procedure argument))))
  203.               ((eq? procedure ^r-lisp-insert-paren-command)      ;3.02
  204.                (procedure argument))                ;3.02
  205.           (else
  206.                (cache-paren-mark '())                ;3.02
  207.            (procedure argument))))))
  208.  
  209. (define (current-command-char)
  210.   (fluid *command-char*))
  211.  
  212. (define (current-command)
  213.   (fluid *command*))
  214.  
  215. (define (set-command-message! tag . arguments)
  216.   (set-fluid! *next-message* (cons tag arguments)))
  217.  
  218. (define (command-message-receive tag if-received if-not-received)
  219.   (if (and (fluid *command-message*)
  220.        (eq? (car (fluid *command-message*)) tag))
  221.       (apply if-received (cdr (fluid *command-message*)))
  222.       (if-not-received)))
  223.  
  224. (define (beep)
  225.   (princ ^G-char typein-screen))
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.