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 / usrint.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  269 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: usrint.scm,v 1.16 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1991-1999 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; User Interface
  23. ;;; package: (runtime user-interface)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Prompting
  28.  
  29. (define (canonicalize-prompt prompt suffix)
  30.   (if (let ((length (string-length prompt)))
  31.     (and (not (fix:= length 0))
  32.          (char=? (string-ref prompt (fix:- length 1)) #\space)))
  33.       prompt
  34.       (string-append prompt suffix)))
  35.  
  36. (define (canonicalize-command-prompt prompt)
  37.   (cond ((string? prompt)
  38.      prompt)
  39.     ((and (pair? prompt)
  40.           (eq? 'STANDARD (car prompt))
  41.           (string? (cdr prompt)))
  42.      (cons (car prompt) (canonicalize-prompt (cdr prompt) " ")))
  43.     (else
  44.      (error:wrong-type-datum prompt "a string or standard prompt"))))
  45.  
  46. (define (write-command-prompt port prompt level)
  47.   (port/with-output-terminal-mode port 'COOKED
  48.     (lambda ()
  49.       (fresh-line port)
  50.       (newline port)
  51.       (if (and (pair? prompt)
  52.            (eq? 'STANDARD (car prompt)))
  53.       (begin
  54.         (write level port)
  55.         (write-string " " port)
  56.         (write-string (cdr prompt) port))
  57.       (write-string prompt port))
  58.       (flush-output port))))
  59.  
  60. (define (prompt-for-command-expression prompt #!optional port)
  61.   (let ((prompt (canonicalize-command-prompt prompt))
  62.     (port (if (default-object? port) (interaction-i/o-port) port))
  63.     (level (nearest-cmdl/level)))
  64.     (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-EXPRESSION)))
  65.       (if operation
  66.       (operation port prompt level)
  67.       (default/prompt-for-command-expression port prompt level)))))
  68.  
  69. (define (default/prompt-for-command-expression port prompt level)
  70.   (write-command-prompt port prompt level)
  71.   (port/with-input-terminal-mode port 'COOKED
  72.     (lambda ()
  73.       (read port))))
  74.  
  75. (define (prompt-for-expression prompt #!optional port)
  76.   (let ((prompt (canonicalize-prompt prompt ": "))
  77.     (port (if (default-object? port) (interaction-i/o-port) port)))
  78.     (let ((operation (port/operation port 'PROMPT-FOR-EXPRESSION)))
  79.       (if operation
  80.       (operation port prompt)
  81.       (default/prompt-for-expression port prompt)))))
  82.  
  83. (define (default/prompt-for-expression port prompt)
  84.   (port/with-output-terminal-mode port 'COOKED
  85.     (lambda ()
  86.       (fresh-line port)
  87.       (newline port)
  88.       (write-string prompt port)
  89.       (flush-output port)))
  90.   (port/with-input-terminal-mode port 'COOKED
  91.     (lambda ()
  92.       (read port))))
  93.  
  94. (define (prompt-for-evaluated-expression prompt #!optional environment port)
  95.   (hook/repl-eval #f
  96.           (prompt-for-expression prompt
  97.                      (if (default-object? port)
  98.                          (interaction-i/o-port)
  99.                          port))
  100.           (if (default-object? environment)
  101.               (nearest-repl/environment)
  102.               environment)
  103.           (nearest-repl/syntax-table)))
  104.  
  105. (define (prompt-for-command-char prompt #!optional port)
  106.   (let ((prompt (canonicalize-command-prompt prompt))
  107.     (port (if (default-object? port) (interaction-i/o-port) port))
  108.     (level (nearest-cmdl/level)))
  109.     (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-CHAR)))
  110.       (if operation
  111.       (operation port prompt level)
  112.       (default/prompt-for-command-char port prompt level)))))
  113.  
  114. (define (default/prompt-for-command-char port prompt level)
  115.   (write-command-prompt port prompt level)
  116.   (let loop ()
  117.     (let ((char
  118.        (port/with-input-terminal-mode port 'RAW
  119.          (lambda ()
  120.            (read-char port)))))
  121.       (if (char-graphic? char)
  122.       (begin
  123.         (port/with-output-terminal-mode port 'COOKED
  124.           (lambda ()
  125.         (write-char char port)
  126.         (flush-output port)))
  127.         char)
  128.       (loop)))))
  129.  
  130. (define (prompt-for-confirmation prompt #!optional port)
  131.   (let ((prompt (canonicalize-prompt prompt " (y or n)? "))
  132.     (port (if (default-object? port) (interaction-i/o-port) port)))
  133.     (let ((operation (port/operation port 'PROMPT-FOR-CONFIRMATION)))
  134.       (if operation
  135.       (operation port prompt)
  136.       (default/prompt-for-confirmation port prompt)))))
  137.  
  138. (define (default/prompt-for-confirmation port prompt)
  139.   (port/with-output-terminal-mode port 'COOKED
  140.     (lambda ()
  141.       (fresh-line port)))
  142.   (let loop ()
  143.     (port/with-output-terminal-mode port 'COOKED
  144.       (lambda ()
  145.     (newline port)
  146.     (write-string prompt port)
  147.     (flush-output port)))
  148.     (let ((char
  149.        (port/with-input-terminal-mode port 'RAW
  150.          (lambda ()
  151.            (read-char port)))))
  152.       (case char
  153.     ((#\y #\Y #\space)
  154.      (port/with-output-terminal-mode port 'COOKED
  155.        (lambda ()
  156.          (write-string "Yes" port)
  157.          (flush-output port)))
  158.      true)
  159.     ((#\n #\N #\rubout)
  160.      (port/with-output-terminal-mode port 'COOKED
  161.        (lambda ()
  162.          (write-string "No" port)
  163.          (flush-output port)))
  164.      false)
  165.     ((#\newline)
  166.      (loop))
  167.     (else
  168.      (port/with-output-terminal-mode port 'COOKED
  169.        (lambda ()
  170.          (write char port)
  171.          (beep port)
  172.          (flush-output port)))
  173.      (loop))))))
  174.  
  175. ;;;; Debugger Support
  176.  
  177. (define (port/debugger-failure port message)
  178.   (let ((operation (port/operation port 'DEBUGGER-FAILURE)))
  179.     (if operation
  180.     (operation port message)
  181.     (default/debugger-failure port message))))
  182.  
  183. (define (default/debugger-failure port message)
  184.   (beep port)
  185.   (default/debugger-message port message))
  186.  
  187. (define (port/debugger-message port message)
  188.   (let ((operation (port/operation port 'DEBUGGER-MESSAGE)))
  189.     (if operation
  190.     (operation port message)
  191.     (default/debugger-message port message))))
  192.  
  193. (define (default/debugger-message port message)
  194.   (fresh-line port)
  195.   (write-string message port))
  196.  
  197. (define (port/debugger-presentation port thunk)
  198.   (let ((operation (port/operation port 'DEBUGGER-PRESENTATION)))
  199.     (if operation
  200.     (operation port thunk)
  201.     (default/debugger-presentation port thunk))))
  202.  
  203. (define (default/debugger-presentation port thunk)
  204.   (fresh-line port)
  205.   (thunk))
  206.  
  207. ;;;; Miscellaneous Hooks
  208.  
  209. (define (port/write-result port expression value hash-number)
  210.   (let ((operation (port/operation port 'WRITE-RESULT)))
  211.     (if operation
  212.     (operation port expression value hash-number)
  213.     (default/write-result port expression value hash-number))))
  214.  
  215. (define (default/write-result port expression object hash-number)
  216.   expression
  217.   (port/with-output-terminal-mode port 'COOKED
  218.     (lambda ()
  219.       (fresh-line port)
  220.       (write-string ";" port)
  221.       (if (and write-result:undefined-value-is-special?
  222.            (undefined-value? object))
  223.       (write-string "Unspecified return value" port)
  224.       (begin
  225.         (write-string "Value" port)
  226.         (if hash-number
  227.         (begin
  228.           (write-string " " port)
  229.           (write hash-number port)))
  230.         (write-string ": " port)
  231.         (write object port))))))
  232.  
  233. (define write-result:undefined-value-is-special? true)
  234.  
  235. (define (port/set-default-directory port directory)
  236.   (let ((operation (port/operation port 'SET-DEFAULT-DIRECTORY)))
  237.     (if operation
  238.     (operation port directory))))
  239.  
  240. (define (port/set-default-environment port environment)
  241.   (let ((operation (port/operation port 'SET-DEFAULT-ENVIRONMENT)))
  242.     (if operation
  243.     (operation port environment))))
  244.  
  245. (define (port/set-default-syntax-table port syntax-table)
  246.   (let ((operation (port/operation port 'SET-DEFAULT-SYNTAX-TABLE)))
  247.     (if operation
  248.     (operation port syntax-table))))
  249.  
  250. (define (port/gc-start port)
  251.   (let ((operation (port/operation port 'GC-START)))
  252.     (if (and operation (not *within-restore-window?*))
  253.     (operation port))))
  254.  
  255. (define (port/gc-finish port)
  256.   (let ((operation (port/operation port 'GC-FINISH)))
  257.     (if (and operation (not *within-restore-window?*))
  258.     (operation port))))
  259.  
  260. (define (port/read-start port)
  261.   (let ((operation (port/operation port 'READ-START)))
  262.     (if operation
  263.     (operation port))))
  264.  
  265. (define (port/read-finish port)
  266.   (let ((operation (port/operation port 'READ-FINISH)))
  267.     (if operation
  268.     (operation port))))
  269.