module/system/repl/common.scm

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