module/system/repl/common.scm

   1 ;;; Repl common routines
   2
   3 ;; Copyright (C) 2001, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   4
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (system repl common)
  22   #:use-module (system base syntax)
  23   #:use-module (system base compile)
  24   #:use-module (system base language)
  25   #:use-module (system base message)
  26   #:use-module (system vm program)
  27   #:autoload (language tree-il optimize) (optimize!)
  28   #:use-module (ice-9 control)
  29   #:use-module (ice-9 history)
  30   #:export (<repl> make-repl repl-language repl-options
  31             repl-tm-stats repl-gc-stats repl-debug
  32             repl-welcome repl-prompt
  33             repl-read repl-compile repl-prepare-eval-thunk repl-eval
  34             repl-expand repl-optimize
  35             repl-parse repl-print repl-option-ref repl-option-set!
  36             repl-default-option-set! repl-default-prompt-set!
  37             puts ->string user-error
  38             *warranty* *copying* *version*))
  39
  40 (define *version*
  41   (format #f "GNU Guile ~A
  42 Copyright (C) 1995-2011 Free Software Foundation, Inc.
  43
  44 Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
  45 This program is free software, and you are welcome to redistribute it
  46 under certain conditions; type `,show c' for details." (version)))
  47
  48 (define *copying*
  49 "Guile is free software: you can redistribute it and/or modify
  50 it under the terms of the GNU Lesser General Public License as
  51 published by the Free Software Foundation, either version 3 of
  52 the License, or (at your option) any later version.
  53
  54 Guile is distributed in the hope that it will be useful, but
  55 WITHOUT ANY WARRANTY; without even the implied warranty of
  56 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  57 Lesser General Public License for more details.
  58
  59 You should have received a copy of the GNU Lesser General Public
  60 License along with this program. If not, see
  61 <http://www.gnu.org/licenses/lgpl.html>.")
  62
  63 (define *warranty*
  64 "Guile is distributed WITHOUT ANY WARRANTY. The following
  65 sections from the GNU General Public License, version 3, should
  66 make that clear.
  67
  68   15. Disclaimer of Warranty.
  69
  70   THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
  71 APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
  72 HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY
  73 OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
  74 THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  75 PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
  76 IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
  77 ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
  78
  79   16. Limitation of Liability.
  80
  81   IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
  82 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
  83 THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
  84 GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
  85 USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
  86 DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
  87 PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
  88 EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
  89 SUCH DAMAGES.
  90
  91   17. Interpretation of Sections 15 and 16.
  92
  93   If the disclaimer of warranty and limitation of liability provided
  94 above cannot be given local legal effect according to their terms,
  95 reviewing courts shall apply local law that most closely approximates
  96 an absolute waiver of all civil liability in connection with the
  97 Program, unless a warranty or assumption of liability accompanies a
  98 copy of the Program in return for a fee.
  99
 100 See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
 101
 102 \f
 103 ;;;
 104 ;;; Repl type
 105 ;;;
 106
 107 (define-record/keywords <repl>
 108   language options tm-stats gc-stats debug)
 109
 110 (define repl-default-options
 111   (copy-tree
 112    `((compile-options ,%auto-compilation-options #f)
 113      (trace #f #f)
 114      (interp #f #f)
 115      (prompt #f ,(lambda (prompt)
 116                    (cond
 117                     ((not prompt) #f)
 118                     ((string? prompt) (lambda (repl) prompt))
 119                     ((thunk? prompt) (lambda (repl) (prompt)))
 120                     ((procedure? prompt) prompt)
 121                     (else (error "Invalid prompt" prompt)))))
 122      (value-history
 123       ,(value-history-enabled?)
 124       ,(lambda (x)
 125          (if x (enable-value-history!) (disable-value-history!))
 126          (->bool x)))
 127      (on-error
 128       debug
 129       ,(let ((vals '(debug backtrace report pass)))
 130          (lambda (x)
 131            (if (memq x vals)
 132                x
 133                (error "Bad on-error value ~a; expected one of ~a" x vals))))))))
 134
 135 (define %make-repl make-repl)
 136 (define* (make-repl lang #:optional debug)
 137   (%make-repl #:language (lookup-language lang)
 138               #:options (copy-tree repl-default-options)
 139               #:tm-stats (times)
 140               #:gc-stats (gc-stats)
 141               #:debug debug))
 142
 143 (define (repl-welcome repl)
 144   (display *version*)
 145   (newline)
 146   (newline)
 147   (display "Enter `,help' for help.\n"))
 148
 149 (define (repl-prompt repl)
 150   (cond
 151    ((repl-option-ref repl 'prompt)
 152     => (lambda (prompt) (prompt repl)))
 153    (else
 154     (format #f "~A@~A~A> " (language-name (repl-language repl))
 155             (module-name (current-module))
 156             (let ((level (length (cond
 157                                   ((fluid-ref *repl-stack*) => cdr)
 158                                   (else '())))))
 159               (if (zero? level) "" (format #f " [~a]" level)))))))
 160
 161 (define (repl-read repl)
 162   (let ((reader (language-reader (repl-language repl))))
 163     (reader (current-input-port) (current-module))))
 164
 165 (define (repl-compile-options repl)
 166   (repl-option-ref repl 'compile-options))
 167
 168 (define (repl-compile repl form)
 169   (let ((from (repl-language repl))
 170         (opts (repl-compile-options repl)))
 171     (compile form #:from from #:to 'objcode #:opts opts
 172              #:env (current-module))))
 173
 174 (define (repl-expand repl form)
 175   (let ((from (repl-language repl))
 176         (opts (repl-compile-options repl)))
 177     (decompile (compile form #:from from #:to 'tree-il #:opts opts
 178                         #:env (current-module))
 179                #:from 'tree-il #:to from)))
 180
 181 (define (repl-optimize repl form)
 182   (let ((from (repl-language repl))
 183         (opts (repl-compile-options repl)))
 184     (decompile (optimize! (compile form #:from from #:to 'tree-il #:opts opts
 185                                    #:env (current-module))
 186                           (current-module)
 187                           opts)
 188                #:from 'tree-il #:to from)))
 189
 190 (define (repl-parse repl form)
 191   (let ((parser (language-parser (repl-language repl))))
 192     (if parser (parser form) form)))
 193
 194 (define (repl-prepare-eval-thunk repl form)
 195   (let* ((eval (language-evaluator (repl-language repl))))
 196     (if (and eval
 197              (or (null? (language-compilers (repl-language repl)))
 198                  (repl-option-ref repl 'interp)))
 199         (lambda () (eval form (current-module)))
 200         (make-program (repl-compile repl form)))))
 201
 202 (define (repl-eval repl form)
 203   (let ((thunk (repl-prepare-eval-thunk repl form)))
 204     (% (thunk))))
 205
 206 (define (repl-print repl val)
 207   (if (not (eq? val *unspecified*))
 208       (begin
 209         (run-hook before-print-hook val)
 210         ;; The result of an evaluation is representable in scheme, and
 211         ;; should be printed with the generic printer, `write'. The
 212         ;; language-printer is something else: it prints expressions of
 213         ;; a given language, not the result of evaluation.
 214         (write val)
 215         (newline))))
 216
 217 (define (repl-option-ref repl key)
 218   (cadr (or (assq key (repl-options repl))
 219             (error "unknown repl option" key))))
 220
 221 (define (repl-option-set! repl key val)
 222   (let ((spec (or (assq key (repl-options repl))
 223                   (error "unknown repl option" key))))
 224     (set-car! (cdr spec)
 225               (if (procedure? (caddr spec))
 226                   ((caddr spec) val)
 227                   val))))
 228
 229 (define (repl-default-option-set! key val)
 230   (let ((spec (or (assq key repl-default-options)
 231                   (error "unknown repl option" key))))
 232     (set-car! (cdr spec)
 233               (if (procedure? (caddr spec))
 234                   ((caddr spec) val)
 235                   val))))
 236
 237 (define (repl-default-prompt-set! prompt)
 238   (repl-default-option-set! 'prompt prompt))
 239
 240 \f
 241 ;;;
 242 ;;; Utilities
 243 ;;;
 244
 245 (define (puts x) (display x) (newline))
 246
 247 (define (->string x)
 248   (object->string x display))
 249
 250 (define (user-error msg . args)
 251   (throw 'user-error #f msg args #f))