;;; Repl common routines
-;; Copyright (C) 2001, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
#:use-module (system base syntax)
#:use-module (system base compile)
#:use-module (system base language)
+ #:use-module (system base message)
#:use-module (system vm program)
+ #:autoload (language tree-il optimize) (optimize!)
#:use-module (ice-9 control)
+ #:use-module (ice-9 history)
#:export (<repl> make-repl repl-language repl-options
- repl-tm-stats repl-gc-stats
- repl-welcome repl-prompt repl-read repl-compile repl-eval
+ repl-tm-stats repl-gc-stats repl-debug
+ repl-welcome repl-prompt
+ repl-read repl-compile repl-prepare-eval-thunk repl-eval
+ repl-expand repl-optimize
repl-parse repl-print repl-option-ref repl-option-set!
repl-default-option-set! repl-default-prompt-set!
puts ->string user-error
(define *version*
(format #f "GNU Guile ~A
-Copyright (C) 1995-2010 Free Software Foundation, Inc.
+Copyright (C) 1995-2011 Free Software Foundation, Inc.
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
;;; Repl type
;;;
-(define-record/keywords <repl> language options tm-stats gc-stats)
+(define-record/keywords <repl>
+ language options tm-stats gc-stats debug)
(define repl-default-options
- '((trace . #f)
- (interp . #f)))
+ (copy-tree
+ `((compile-options ,%auto-compilation-options #f)
+ (trace #f #f)
+ (interp #f #f)
+ (prompt #f ,(lambda (prompt)
+ (cond
+ ((not prompt) #f)
+ ((string? prompt) (lambda (repl) prompt))
+ ((thunk? prompt) (lambda (repl) (prompt)))
+ ((procedure? prompt) prompt)
+ (else (error "Invalid prompt" prompt)))))
+ (value-history
+ ,(value-history-enabled?)
+ ,(lambda (x)
+ (if x (enable-value-history!) (disable-value-history!))
+ (->bool x)))
+ (on-error
+ debug
+ ,(let ((vals '(debug backtrace report pass)))
+ (lambda (x)
+ (if (memq x vals)
+ x
+ (error "Bad on-error value ~a; expected one of ~a" x vals))))))))
(define %make-repl make-repl)
-(define (make-repl lang)
- (%make-repl #:language (lookup-language lang)
- #:options repl-default-options
+(define* (make-repl lang #:optional debug)
+ (%make-repl #:language (if (language? lang)
+ lang
+ (lookup-language lang))
+ #:options (copy-tree repl-default-options)
#:tm-stats (times)
- #:gc-stats (gc-stats)))
+ #:gc-stats (gc-stats)
+ #:debug debug))
(define (repl-welcome repl)
(display *version*)
(else
(format #f "~A@~A~A> " (language-name (repl-language repl))
(module-name (current-module))
- (let ((level (or (fluid-ref *repl-level*) 0)))
+ (let ((level (length (cond
+ ((fluid-ref *repl-stack*) => cdr)
+ (else '())))))
(if (zero? level) "" (format #f " [~a]" level)))))))
(define (repl-read repl)
- ((language-reader (repl-language repl)) (current-input-port)
- (current-module)))
-
-(define (repl-compile repl form . opts)
- (let ((to (lookup-language (cond ((memq #:e opts) 'scheme)
- ((memq #:t opts) 'ghil)
- ((memq #:c opts) 'glil)
- (else 'objcode))))
- (from (repl-language repl)))
- (compile form #:from from #:to to #:opts opts #:env (current-module))))
+ (let ((reader (language-reader (repl-language repl))))
+ (reader (current-input-port) (current-module))))
+
+(define (repl-compile-options repl)
+ (repl-option-ref repl 'compile-options))
+
+(define (repl-compile repl form)
+ (let ((from (repl-language repl))
+ (opts (repl-compile-options repl)))
+ (compile form #:from from #:to 'objcode #:opts opts
+ #:env (current-module))))
+
+(define (repl-expand repl form)
+ (let ((from (repl-language repl))
+ (opts (repl-compile-options repl)))
+ (decompile (compile form #:from from #:to 'tree-il #:opts opts
+ #:env (current-module))
+ #:from 'tree-il #:to from)))
+
+(define (repl-optimize repl form)
+ (let ((from (repl-language repl))
+ (opts (repl-compile-options repl)))
+ (decompile (optimize! (compile form #:from from #:to 'tree-il #:opts opts
+ #:env (current-module))
+ (current-module)
+ opts)
+ #:from 'tree-il #:to from)))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))
(if parser (parser form) form)))
+(define (repl-prepare-eval-thunk repl form)
+ (let* ((eval (language-evaluator (repl-language repl))))
+ (if (and eval
+ (or (null? (language-compilers (repl-language repl)))
+ (repl-option-ref repl 'interp)))
+ (lambda () (eval form (current-module)))
+ (make-program (repl-compile repl form)))))
+
(define (repl-eval repl form)
- (let* ((eval (language-evaluator (repl-language repl)))
- (thunk (if (and eval
- (or (null? (language-compilers (repl-language repl)))
- (assq-ref (repl-options repl) 'interp)))
- (lambda () (eval form (current-module)))
- (make-program (repl-compile repl form '())))))
+ (let ((thunk (repl-prepare-eval-thunk repl form)))
(% (thunk))))
(define (repl-print repl val)
(if (not (eq? val *unspecified*))
(begin
+ (run-hook before-print-hook val)
;; The result of an evaluation is representable in scheme, and
;; should be printed with the generic printer, `write'. The
;; language-printer is something else: it prints expressions of
(newline))))
(define (repl-option-ref repl key)
- (assq-ref (repl-options repl) key))
+ (cadr (or (assq key (repl-options repl))
+ (error "unknown repl option" key))))
(define (repl-option-set! repl key val)
- (set! (repl-options repl) (assq-set! (repl-options repl) key val)))
+ (let ((spec (or (assq key (repl-options repl))
+ (error "unknown repl option" key))))
+ (set-car! (cdr spec)
+ (if (procedure? (caddr spec))
+ ((caddr spec) val)
+ val))))
(define (repl-default-option-set! key val)
- (set! repl-default-options (assq-set! repl-default-options key val)))
+ (let ((spec (or (assq key repl-default-options)
+ (error "unknown repl option" key))))
+ (set-car! (cdr spec)
+ (if (procedure? (caddr spec))
+ ((caddr spec) val)
+ 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)))))
+ (repl-default-option-set! 'prompt prompt))
\f
;;;
HCoop / bpt / guile.git / blobdiff