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