module/system/repl/common.scm

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