mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

add repl-default-option-set! in (system repl common)

Browse source 
* module/system/repl/common.scm (repl-default-option-set!): New
  interface.
  (repl-default-prompt-set!): New procedure, sets the 'prompt property
  in the default env.
  (repl-prompt): Use the 'prompt repl option if available.
This commit is contained in:
Andy Wingo 2010-06-18 11:29:25 +02:00
parent 40f17f1e0a
commit 91037860bd
1 changed files with 21 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

25
module/system/repl/common.scm
View file

@ -28,6 +28,7 @@
repl-tm-stats repl-gc-stats
repl-welcome repl-prompt repl-read repl-compile repl-eval
repl-parse repl-print repl-option-ref repl-option-set!
repl-default-option-set! repl-default-prompt-set!
puts ->string user-error
*warranty* *copying* *version*
*repl-level*))
@ -121,10 +122,14 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(display "Enter `,help' for help.\n"))
(define (repl-prompt repl)
(format #f "~A@~A~A> " (language-name (repl-language repl))
(module-name (current-module))
(let ((level (or (fluid-ref *repl-level*) 0)))
(if (zero? level) "" (format #f " [~a]" level)))))
(cond
((repl-option-ref repl 'prompt)
=> (lambda (prompt) (prompt repl)))
(else
(format #f "~A@~A~A> " (language-name (repl-language repl))
(module-name (current-module))
(let ((level (or (fluid-ref *repl-level*) 0)))
(if (zero? level) "" (format #f " [~a]" level)))))))
(define (repl-read repl)
((language-reader (repl-language repl)) (current-input-port)
@ -167,6 +172,18 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(define (repl-option-set! repl key val)
(set! (repl-options repl) (assq-set! (repl-options repl) key val)))
(define (repl-default-option-set! key val)
(set! repl-default-options (assq-set! repl-default-options key val)))
(define (repl-default-prompt-set! prompt)
(repl-default-option-set!
'prompt
(cond
((string? prompt) (lambda (repl) prompt))
((thunk? prompt) (lambda (repl) (prompt)))
((procedure? prompt) prompt)
(else (error "Invalid prompt" prompt)))))
;;;
;;; Utilities