repl.scm 7.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230
  1. ;;; Read-Eval-Print Loop
  2. ;; Copyright (C) 2001, 2009, 2010, 2011, 2013,
  3. ;; 2014 Free Software Foundation, Inc.
  4. ;; This library is free software; you can redistribute it and/or
  5. ;; modify it under the terms of the GNU Lesser General Public
  6. ;; License as published by the Free Software Foundation; either
  7. ;; version 3 of the License, or (at your option) any later version.
  8. ;;
  9. ;; This library is distributed in the hope that it will be useful,
  10. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;; Lesser General Public License for more details.
  13. ;;
  14. ;; You should have received a copy of the GNU Lesser General Public
  15. ;; License along with this library; if not, write to the Free Software
  16. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17. ;; 02110-1301 USA
  18. ;;; Code:
  19. (define-module (system repl repl)
  20. #:use-module (system base language)
  21. #:use-module (system repl error-handling)
  22. #:use-module (system repl common)
  23. #:use-module (system repl command)
  24. #:use-module (ice-9 control)
  25. #:export (start-repl run-repl))
  26. ;;;
  27. ;;; Comments
  28. ;;;
  29. ;;; (You don't want a comment to force a continuation line.)
  30. ;;;
  31. (define (read-scheme-line-comment port)
  32. (let lp ()
  33. (let ((ch (read-char port)))
  34. (or (eof-object? ch)
  35. (eqv? ch #\newline)
  36. (lp)))))
  37. (define (read-scheme-datum-comment port)
  38. (read port))
  39. ;; ch is a peeked char
  40. (define (read-comment lang port ch)
  41. (and (eq? (language-name lang) 'scheme)
  42. (case ch
  43. ((#\;)
  44. (read-char port)
  45. (read-scheme-line-comment port)
  46. #t)
  47. ((#\#)
  48. (read-char port)
  49. (case (peek-char port)
  50. ((#\;)
  51. (read-char port)
  52. (read-scheme-datum-comment port)
  53. #t)
  54. ;; Not doing R6RS block comments because of the possibility
  55. ;; of read-hash extensions. Lame excuse. Not doing scsh
  56. ;; block comments either, because I don't feel like handling
  57. ;; #!r6rs.
  58. (else
  59. (unread-char #\# port)
  60. #f)))
  61. (else
  62. #f))))
  63. ;;;
  64. ;;; Meta commands
  65. ;;;
  66. (define meta-command-token (cons 'meta 'command))
  67. (define (meta-reader lang env)
  68. (lambda* (#:optional (port (current-input-port)))
  69. (with-input-from-port port
  70. (lambda ()
  71. (let ((ch (flush-leading-whitespace)))
  72. (cond ((eof-object? ch)
  73. (read-char)) ; consume the EOF and return it
  74. ((eqv? ch #\,)
  75. (read-char)
  76. meta-command-token)
  77. ((read-comment lang port ch)
  78. *unspecified*)
  79. (else ((language-reader lang) port env))))))))
  80. (define (flush-all-input)
  81. (if (and (char-ready?)
  82. (not (eof-object? (peek-char))))
  83. (begin
  84. (read-char)
  85. (flush-all-input))))
  86. ;; repl-reader is a function defined in boot-9.scm, and is replaced by
  87. ;; something else if readline has been activated. much of this hoopla is
  88. ;; to be able to re-use the existing readline machinery.
  89. ;;
  90. ;; Catches read errors, returning *unspecified* in that case.
  91. ;;
  92. ;; Note: although not exported, this is used by (system repl coop-server)
  93. (define (prompting-meta-read repl)
  94. (catch #t
  95. (lambda ()
  96. (repl-reader (lambda () (repl-prompt repl))
  97. (meta-reader (repl-language repl) (current-module))))
  98. (lambda (key . args)
  99. (case key
  100. ((quit)
  101. (apply throw key args))
  102. (else
  103. (format (current-output-port) "While reading expression:\n")
  104. (print-exception (current-output-port) #f key args)
  105. (flush-all-input)
  106. *unspecified*)))))
  107. ;;;
  108. ;;; The repl
  109. ;;;
  110. (define* (start-repl #:optional (lang (current-language)) #:key debug)
  111. (start-repl* lang debug prompting-meta-read))
  112. ;; Note: although not exported, this is used by (system repl coop-server)
  113. (define (start-repl* lang debug prompting-meta-read)
  114. ;; ,language at the REPL will update the current-language. Make
  115. ;; sure that it does so in a new dynamic scope.
  116. (parameterize ((current-language lang))
  117. (run-repl* (make-repl lang debug) prompting-meta-read)))
  118. ;; (put 'abort-on-error 'scheme-indent-function 1)
  119. (define-syntax-rule (abort-on-error string exp)
  120. (catch #t
  121. (lambda () exp)
  122. (lambda (key . args)
  123. (format #t "While ~A:~%" string)
  124. (print-exception (current-output-port) #f key args)
  125. (abort))))
  126. (define (run-repl repl)
  127. (run-repl* repl prompting-meta-read))
  128. (define (run-repl* repl prompting-meta-read)
  129. (define (with-stack-and-prompt thunk)
  130. (call-with-prompt (default-prompt-tag)
  131. (lambda () (start-stack #t (thunk)))
  132. (lambda (k proc)
  133. (with-stack-and-prompt (lambda () (proc k))))))
  134. (% (with-fluids ((*repl-stack*
  135. (cons repl (or (fluid-ref *repl-stack*) '()))))
  136. (if (null? (cdr (fluid-ref *repl-stack*)))
  137. (repl-welcome repl))
  138. (let prompt-loop ()
  139. (let ((exp (prompting-meta-read repl)))
  140. (cond
  141. ((eqv? exp *unspecified*)) ; read error or comment, pass
  142. ((eq? exp meta-command-token)
  143. (catch #t
  144. (lambda ()
  145. (meta-command repl))
  146. (lambda (k . args)
  147. (if (eq? k 'quit)
  148. (abort args)
  149. (begin
  150. (format #t "While executing meta-command:~%")
  151. (print-exception (current-output-port) #f k args))))))
  152. ((eof-object? exp)
  153. (newline)
  154. (abort '()))
  155. (else
  156. ;; since the input port is line-buffered, consume up to the
  157. ;; newline
  158. (flush-to-newline)
  159. (call-with-error-handling
  160. (lambda ()
  161. (catch 'quit
  162. (lambda ()
  163. (call-with-values
  164. (lambda ()
  165. (% (let ((thunk
  166. (abort-on-error "compiling expression"
  167. (repl-prepare-eval-thunk
  168. repl
  169. (abort-on-error "parsing expression"
  170. (repl-parse repl exp))))))
  171. (run-hook before-eval-hook exp)
  172. (call-with-error-handling
  173. (lambda ()
  174. (with-stack-and-prompt thunk))
  175. #:on-error (repl-option-ref repl 'on-error)))
  176. (lambda (k) (values))))
  177. (lambda l
  178. (for-each (lambda (v)
  179. (repl-print repl v))
  180. l))))
  181. (lambda (k . args)
  182. (abort args))))
  183. #:on-error (repl-option-ref repl 'on-error)
  184. #:trap-handler 'disabled)))
  185. (flush-to-newline) ;; consume trailing whitespace
  186. (prompt-loop))))
  187. (lambda (k status)
  188. status)))
  189. ;; Returns first non-whitespace char.
  190. (define (flush-leading-whitespace)
  191. (let ((ch (peek-char)))
  192. (cond ((eof-object? ch) ch)
  193. ((char-whitespace? ch) (read-char) (flush-leading-whitespace))
  194. (else ch))))
  195. (define (flush-to-newline)
  196. (if (char-ready?)
  197. (let ((ch (peek-char)))
  198. (if (and (not (eof-object? ch)) (char-whitespace? ch))
  199. (begin
  200. (read-char)
  201. (if (not (char=? ch #\newline))
  202. (flush-to-newline)))))))