code:
;;; Repl commands

;; Copyright (C) 2001, 2009, 2010 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
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA

;;; Code:

(define-module (system repl command)
  #:use-module (system base syntax)
  #:use-module (system base pmatch)
  #:use-module (system base compile)
  #:use-module (system repl common)
  #:use-module (system repl debug)
  #:use-module (system vm objcode)
  #:use-module (system vm program)
  #:use-module (system vm vm)
  #:autoload (system base language) (lookup-language language-reader)
  #:autoload (system vm trace) (vm-trace)
  #:autoload (system vm profile) (vm-profile)
  #:use-module (ice-9 format)
  #:use-module (ice-9 session)
  #:use-module (ice-9 documentation)
  #:use-module (ice-9 and-let-star)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 control)
  #:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
  #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
  #:use-module (statprof)
  #:export (meta-command))

;;;
;;; Meta command interface
;;;

(define *command-table*
  '((help     (help h) (show s) (apropos a) (describe d))
    (module   (module m) (import use) (load l) (binding b))
    (language (language L))
    (compile  (compile c) (compile-file cc)
	      (disassemble x) (disassemble-file xx))
    (profile  (time t) (profile pr) (trace tr))
    (debug    (backtrace bt) (up) (down) (frame fr)
              (procedure proc) (locals))
    (inspect  (inspect i) (pretty-print pp))
    (system   (gc) (statistics stat) (option o)
              (quit q continue cont))))

(define *show-table*
  '((show (warranty w) (copying c) (version v))))

(define (group-name g) (car g))
(define (group-commands g) (cdr g))

(define *command-module* (current-module))
(define (command-name c) (car c))
(define (command-abbrevs c) (cdr c))
(define (command-procedure c) (module-ref *command-module* (command-name c)))
(define (command-doc c) (procedure-documentation (command-procedure c)))

(define (command-usage c)
  (let ((doc (command-doc c)))
    (substring doc 0 (string-index doc #\newline))))

(define (command-summary c)
  (let* ((doc (command-doc c))
	 (start (1+ (string-index doc #\newline))))
    (cond ((string-index doc #\newline start)
	   => (lambda (end) (substring doc start end)))
	  (else (substring doc start)))))

(define (lookup-group name)
  (assq name *command-table*))

(define* (lookup-command key #:optional (table *command-table*))
  (let loop ((groups table) (commands '()))
    (cond ((and (null? groups) (null? commands)) #f)
	  ((null? commands)
	   (loop (cdr groups) (cdar groups)))
	  ((memq key (car commands)) (car commands))
	  (else (loop groups (cdr commands))))))

(define* (display-group group #:optional (abbrev? #t))
  (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?)
  (for-each (lambda (c)
	      (display-summary (command-usage c)
			       (if abbrev? (command-abbrevs c) '())
			       (command-summary c)))
	    (group-commands group))
  (newline))

(define (display-command command)
  (display "Usage: ")
  (display (command-doc command))
  (newline))

(define (display-summary usage abbrevs summary)
  (let* ((usage-len (string-length usage))
         (abbrevs (if (pair? abbrevs)
                      (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
                      ""))
         (abbrevs-len (string-length abbrevs)))
    (format #t " ,~A~A~A - ~A\n"
            usage
            (cond
             ((> abbrevs-len 32)
              (error "abbrevs too long" abbrevs))
             ((> (+ usage-len abbrevs-len) 32)
              (format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
             (else
              (format #f "~v_" (- 32 abbrevs-len usage-len))))
            abbrevs
            summary)))

(define (read-command repl)
  (catch #t
    (lambda () (read (repl-inport repl)))
    (lambda (key . args)
      (pmatch args
        ((,subr ,msg ,args . ,rest)
         (format #t "Throw to key `~a' while reading command:\n" key)
         (display-error #f (current-output-port) subr msg args rest))
        (else
         (format #t "Throw to key `~a' with args `~s' while reading command.\n"
                 key args)))
      (force-output)
      *unspecified*)))

(define read-line
  (let ((orig-read-line read-line))
    (lambda (repl)
      (orig-read-line (repl-inport repl)))))

(define (meta-command repl)
  (let ((command (read-command repl)))
    (cond
     ((eq? command *unspecified*)) ; read error, already signalled; pass.
     ((not (symbol? command))
      (format #t "Meta-command not a symbol: ~s~%" command))
     ((lookup-command command)
      => (lambda (c) ((command-procedure c) repl)))
     (else
      (format #t "Unknown meta command: ~A~%" command)))))

(define-syntax define-meta-command
  (syntax-rules ()
    ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
     (define (name repl)
       docstring
       (define (handle-read-error form-name key args)
         (pmatch args
           ((,subr ,msg ,args . ,rest)
            (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
                    key form-name 'name)
            (display-error #f (current-output-port) subr msg args rest))
           (else
            (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
                    key args form-name 'name)))
         (abort))

       (% (let* ((expression0
                  (catch #t
                    (lambda ()
                      (repl-reader ""
                                   (lambda* (#:optional (port (repl-inport repl)))
                                     ((language-reader (repl-language repl))
                                      port (current-module)))))
                    (lambda (k . args)
                      (handle-read-error 'expression0 k args))))
                 ...)
            (apply (lambda* datums
                     (with-output-to-port (repl-outport repl)
                       (lambda () b0 b1 ...)))
                   (catch #t
                     (lambda ()
                       (let ((port (open-input-string (read-line repl))))
                         (let lp ((out '()))
                           (let ((x (read port)))
                             (if (eof-object? x)
                                 (reverse out)
                                 (lp (cons x out)))))))
                     (lambda (k . args)
                       (handle-read-error #f k args)))))
          (lambda (k) #f)))) ; the abort handler

    ((_ (name repl . datums) docstring b0 b1 ...)
     (define-meta-command (name repl () . datums)
       docstring b0 b1 ...))))

;;;
;;; Help commands
;;;

(define-meta-command (help repl . args)
  "help [all | GROUP | [-c] COMMAND]
Show help.

With one argument, tries to look up the argument as a group name, giving
help on that group if successful. Otherwise tries to look up the
argument as a command, giving help on the command.

If there is a command whose name is also a group name, use the ,help
-c COMMAND form to give help on the command instead of the group.

Without any argument, a list of help commands and command groups
are displayed."
  (pmatch args
    (()
     (display-group (lookup-group 'help))
     (display "Command Groups:\n\n")
     (display-summary "help all" #f "List all commands")
     (for-each (lambda (g)
		 (let* ((name (symbol->string (group-name g)))
			(usage (string-append "help " name))
			(header (string-append "List " name " commands")))
		   (display-summary usage #f header)))
	       (cdr *command-table*))
     (newline)
     (display
      "Type `,help -c COMMAND' to show documentation of a particular command.")
     (newline))
    ((all)
     (for-each display-group *command-table*))
    ((,group) (guard (lookup-group group))
     (display-group (lookup-group group)))
    ((,command) (guard (lookup-command command))
     (display-command (lookup-command command)))
    ((-c ,command) (guard (lookup-command command))
     (display-command (lookup-command command)))
    ((,command)
     (format #t "Unknown command or group: ~A~%" command))
    ((-c ,command)
     (format #t "Unknown command: ~A~%" command))
    (else
     (format #t "Bad arguments: ~A~%" args))))

(define-meta-command (show repl . args)
  "show [TOPIC]
Gives information about Guile.

With one argument, tries to show a particular piece of information;

currently supported topics are `warranty' (or `w'), `copying' (or `c'),
and `version' (or `v').

Without any argument, a list of topics is displayed."
  (pmatch args
    (()
     (display-group (car *show-table*) #f)
     (newline))
    ((,topic) (guard (lookup-command topic *show-table*))
     ((command-procedure (lookup-command topic *show-table*)) repl))
    ((,command)
     (format #t "Unknown topic: ~A~%" command))
    (else
     (format #t "Bad arguments: ~A~%" args))))

(define (warranty repl)
  "show warranty
Details on the lack of warranty."
  (display *warranty*)
  (newline))

(define (copying repl)
  "show copying
Show the LGPLv3."
  (display *copying*)
  (newline))

(define (version repl)
  "show version
Version information."
  (display *version*)
  (newline))

(define guile:apropos apropos)
(define-meta-command (apropos repl regexp)
  "apropos REGEXP
Find bindings/modules/packages."
  (guile:apropos (->string regexp)))

(define-meta-command (describe repl (form))
  "describe OBJ
Show description/documentation."
  (display (object-documentation (repl-eval repl (repl-parse repl form))))
  (newline))

(define-meta-command (option repl . args)
  "option [KEY VALUE]
List/show/set options."
  (pmatch args
    (()
     (for-each (lambda (spec)
		 (format #t "  ~A~24t~A\n" (car spec) (cadr spec)))
	       (repl-options repl)))
    ((,key)
     (display (repl-option-ref repl key))
     (newline))
    ((,key ,val)
     (repl-option-set! repl key val))))

(define-meta-command (quit repl)
  "quit
Quit this session."
  (throw 'quit))

;;;
;;; Module commands
;;;

(define-meta-command (module repl . args)
  "module [MODULE]
Change modules / Show current module."
  (pmatch args
    (() (puts (module-name (current-module))))
    ((,mod-name) (guard (list? mod-name))
     (set-current-module (resolve-module mod-name)))
    (,mod-name (set-current-module (resolve-module mod-name)))))

(define-meta-command (import repl . args)
  "import [MODULE ...]
Import modules / List those imported."
  (let ()
    (define (use name)
      (let ((mod (resolve-interface name)))
        (if mod
            (module-use! (current-module) mod)
            (format #t "No such module: ~A~%" name))))
    (if (null? args)
        (for-each puts (map module-name (module-uses (current-module))))
        (for-each use args))))

(define guile:load load)
(define-meta-command (load repl file)
  "load FILE
Load a file in the current module."
  (guile:load (->string file)))

(define-meta-command (binding repl)
  "binding
List current bindings."
  (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
                   (current-module)))

;;;
;;; Language commands
;;;

(define-meta-command (language repl name)
  "language LANGUAGE
Change languages."
  (let ((lang (lookup-language name))
        (cur (repl-language repl)))
    (format #t "Happy hacking with ~a!  To switch back, type `,L ~a'.\n"
            (language-title lang) (language-name cur))
    (set! (repl-language repl) lang)))

;;;
;;; Compile commands
;;;

(define-meta-command (compile repl (form))
  "compile EXP
Generate compiled code."
  (let ((x (repl-compile repl (repl-parse repl form))))
    (cond ((objcode? x) (guile:disassemble x))
          (else (repl-print repl x)))))

(define guile:compile-file compile-file)
(define-meta-command (compile-file repl file . opts)
  "compile-file FILE
Compile a file."
  (guile:compile-file (->string file) #:opts opts))

(define (guile:disassemble x)
  ((@ (language assembly disassemble) disassemble) x))

(define-meta-command (disassemble repl (form))
  "disassemble EXP
Disassemble a compiled procedure."
  (guile:disassemble (repl-eval repl (repl-parse repl form))))

(define-meta-command (disassemble-file repl file)
  "disassemble-file FILE
Disassemble a file."
  (guile:disassemble (load-objcode (->string file))))

;;;
;;; Profile commands
;;;

(define-meta-command (time repl (form))
  "time EXP
Time execution."
  (let* ((gc-start (gc-run-time))
	 (tms-start (times))
	 (result (repl-eval repl (repl-parse repl form)))
	 (tms-end (times))
	 (gc-end (gc-run-time)))
    (define (get proc start end)
      (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
    (repl-print repl result)
    (display "clock utime stime cutime cstime gctime\n")
    (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
	    (get tms:clock tms-start tms-end)
	    (get tms:utime tms-start tms-end)
	    (get tms:stime tms-start tms-end)
	    (get tms:cutime tms-start tms-end)
	    (get tms:cstime tms-start tms-end)
	    (get identity gc-start gc-end))
    result))

(define-meta-command (profile repl (form) . opts)
  "profile EXP
Profile execution."
  ;; FIXME opts
  (apply statprof
         (make-program (repl-compile repl (repl-parse repl form)))
         opts))

(define-meta-command (trace repl (form) . opts)
  "trace EXP
Trace execution."
  ;; FIXME: doc options, or somehow deal with them better
  (apply vm-trace
         (the-vm)
         (make-program (repl-compile repl (repl-parse repl form)))
         opts))

;;;
;;; Debug commands
;;;

(define-syntax define-stack-command
  (lambda (x)
    (syntax-case x ()
      ((_ (name repl . args) docstring body body* ...)
       #`(define-meta-command (name repl . args)
           docstring
           (let ((debug (repl-debug repl)))
             (if debug
                 (letrec-syntax
                     ((#,(datum->syntax #'repl 'frames)
                       (identifier-syntax (debug-frames debug)))
                      (#,(datum->syntax #'repl 'index)
                       (identifier-syntax
                        (id (debug-index debug))
                        ((set! id exp) (set! (debug-index debug) exp))))
                      (#,(datum->syntax #'repl 'cur)
                       (identifier-syntax
                        (vector-ref #,(datum->syntax #'repl 'frames)
                                    #,(datum->syntax #'repl 'index)))))
                   body body* ...)
                 (format #t "Nothing to debug.~%"))))))))

(define-stack-command (backtrace repl #:optional count
                                 #:key (width 72) full?)
  "backtrace [COUNT] [#:width W] [#:full? F]
Print a backtrace.

Print a backtrace of all stack frames, or innermost COUNT frames.
If COUNT is negative, the last COUNT frames will be shown."
  (print-frames frames
                #:count count
                #:width width
                #:full? full?))

(define-stack-command (up repl #:optional (count 1))
  "up [COUNT]
Select a calling stack frame.

Select and print stack frames that called this one.
An argument says how many frames up to go."
  (cond
   ((or (not (integer? count)) (<= count 0))
    (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
   ((>= (+ count index) (vector-length frames))
    (cond
     ((= index (1- (vector-length frames)))
      (format #t "Already at outermost frame.\n"))
     (else
      (set! index (1- (vector-length frames)))
      (print-frame cur #:index index))))
   (else
    (set! index (+ count index))
    (print-frame cur #:index index))))

(define-stack-command (down repl #:optional (count 1))
  "down [COUNT]
Select a called stack frame.

Select and print stack frames called by this one.
An argument says how many frames down to go."
  (cond
   ((or (not (integer? count)) (<= count 0))
    (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
   ((< (- index count) 0)
    (cond
     ((zero? index)
      (format #t "Already at innermost frame.\n"))
     (else
      (set! index 0)
      (print-frame cur #:index index))))
   (else
    (set! index (- index count))
    (print-frame cur #:index index))))

(define-stack-command (frame repl #:optional idx)
  "frame [IDX]
Show a frame.

Show the selected frame.
With an argument, select a frame by index, then show it."
  (cond
   (idx
    (cond
     ((or (not (integer? idx)) (< idx 0))
      (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
     ((< idx (vector-length frames))
      (set! index idx)
      (print-frame cur #:index index))
     (else
      (format #t "No such frame.~%"))))
   (else (print-frame cur #:index index))))

(define-stack-command (procedure repl)
  "procedure
Print the procedure for the selected frame."
  (repl-print repl (frame-procedure cur)))

(define-stack-command (locals repl)
  "locals
Show local variables.

Show locally-bound variables in the selected frame."
  (print-locals cur))

;;;
;;; Inspection commands
;;;

(define-stack-command (inspect repl (form))
  "inspect EXP
Inspect the result(s) of evaluating EXP."
  (call-with-values (make-program (repl-compile repl (repl-parse repl form)))
    (lambda args
      (for-each %inspect args))))

(define-meta-command (pretty-print repl (form))
  "pretty-print EXP
Pretty-print the result(s) of evaluating EXP."
  (call-with-values (make-program (repl-compile repl (repl-parse repl form)))
    (lambda args
      (for-each
       (lambda (x)
         (run-hook before-print-hook x)
         (pp x))
       args))))

;;;
;;; System commands
;;;

(define guile:gc gc)
(define-meta-command (gc repl)
  "gc
Garbage collection."
  (guile:gc))

(define-meta-command (statistics repl)
  "statistics
Display statistics."
  (let ((this-tms (times))
	(this-gcs (gc-stats))
	(last-tms (repl-tm-stats repl))
	(last-gcs (repl-gc-stats repl)))
    ;; GC times
    (let ((this-times  (assq-ref this-gcs 'gc-times))
	  (last-times  (assq-ref last-gcs 'gc-times)))
      (display-diff-stat "GC times:" #t this-times last-times "times")
      (newline))
    ;; Memory size
    (let ((this-cells  (assq-ref this-gcs 'cells-allocated))
	  (this-heap   (assq-ref this-gcs 'cell-heap-size))
	  (this-bytes  (assq-ref this-gcs 'bytes-malloced))
	  (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
      (display-stat-title "Memory size:" "current" "limit")
      (display-stat "heap" #f this-cells this-heap "cells")
      (display-stat "malloc" #f this-bytes this-malloc "bytes")
      (newline))
    ;; Cells collected
    (let ((this-marked (assq-ref this-gcs 'cells-marked))
	  (last-marked (assq-ref last-gcs 'cells-marked))
	  (this-swept  (assq-ref this-gcs 'cells-swept))
	  (last-swept  (assq-ref last-gcs 'cells-swept)))
      (display-stat-title "Cells collected:" "diff" "total")
      (display-diff-stat "marked" #f this-marked last-marked "cells")
      (display-diff-stat "swept" #f this-swept last-swept "cells")
      (newline))
    ;; GC time taken
    (let ((this-mark  (assq-ref this-gcs 'gc-mark-time-taken))
	  (last-mark  (assq-ref last-gcs 'gc-mark-time-taken))
	  (this-total (assq-ref this-gcs 'gc-time-taken))
	  (last-total (assq-ref last-gcs 'gc-time-taken)))
      (display-stat-title "GC time taken:" "diff" "total")
      (display-time-stat "mark" this-mark last-mark)
      (display-time-stat "total" this-total last-total)
      (newline))
    ;; Process time spent
    (let ((this-utime  (tms:utime this-tms))
	  (last-utime  (tms:utime last-tms))
	  (this-stime  (tms:stime this-tms))
	  (last-stime  (tms:stime last-tms))
	  (this-cutime (tms:cutime this-tms))
	  (last-cutime (tms:cutime last-tms))
	  (this-cstime (tms:cstime this-tms))
	  (last-cstime (tms:cstime last-tms)))
      (display-stat-title "Process time spent:" "diff" "total")
      (display-time-stat "user" this-utime last-utime)
      (display-time-stat "system" this-stime last-stime)
      (display-time-stat "child user" this-cutime last-cutime)
      (display-time-stat "child system" this-cstime last-cstime)
      (newline))
    ;; Save statistics
    ;; Save statistics
    (set! (repl-tm-stats repl) this-tms)
    (set! (repl-gc-stats repl) this-gcs)))

(define (display-stat title flag field1 field2 unit)
  (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
    (format #t str title field1 field2 unit)))

(define (display-stat-title title field1 field2)
  (display-stat title #t field1 field2 ""))

(define (display-diff-stat title flag this last unit)
  (display-stat title flag (- this last) this unit))

(define (display-time-stat title this last)
  (define (conv num)
    (format #f "~10,2F" (exact->inexact (/ num internal-time-units-per-second))))
  (display-stat title #f (conv (- this last)) (conv this) "s"))

(define (display-mips-stat title this-time this-clock last-time last-clock)
  (define (mips time clock)
    (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000.0))))
  (display-stat title #f
		(mips (- this-time last-time) (- this-clock last-clock))
		(mips this-time this-clock) "mips"))


code:
;;; Repl common routines

;; Copyright (C) 2001, 2008, 2009, 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system repl common)
  #:use-module (system base syntax)
  #:use-module (system base compile)
  #:use-module (system base language)
  #:use-module (system vm program)
  #: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-inport repl-outport repl-debug
            repl-welcome repl-prompt
            repl-read repl-compile repl-prepare-eval-thunk repl-eval
            repl-parse repl-print repl-option-ref repl-option-set!
            repl-default-option-set! repl-default-prompt-set!
            puts ->string user-error
            *warranty* *copying* *version*))

(define *version*
  (format #f "GNU Guile ~A
Copyright (C) 1995-2010 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
under certain conditions; type `,show c' for details." (version)))

(define *copying*
"Guile is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation, either version 3 of
the License, or (at your option) any later version.

Guile is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this program. If not, see
<http://www.gnu.org/licenses/lgpl.html>.")

(define *warranty*
"Guile is distributed WITHOUT ANY WARRANTY. The following
sections from the GNU General Public License, version 3, should
make that clear.

  15. Disclaimer of Warranty.

  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. Limitation of Liability.

  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.

  17. Interpretation of Sections 15 and 16.

  If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.

See <http://www.gnu.org/licenses/lgpl.html>, for more details.")

;;;
;;; Repl type
;;;

(define-record/keywords <repl>
  language options tm-stats gc-stats inport outport debug)

(define repl-default-options
  (copy-tree
   `((compile-options (#:warnings (unbound-variable arity-mismatch)) #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))))))

(define %make-repl make-repl)
(define* (make-repl lang #:optional debug)
  (%make-repl #:language (lookup-language lang)
              #:options (copy-tree repl-default-options)
              #:tm-stats (times)
              #:gc-stats (gc-stats)
              #:inport (current-input-port)
              #:outport (current-output-port)
              #:debug debug))

(define (repl-welcome repl)
  (display *version*)
  (newline)
  (newline)
  (display "Enter `,help' for help.\n"))

(define (repl-prompt repl)
  (cond
   ((repl-option-ref repl 'prompt)
    => (lambda (prompt) (prompt repl)))
   (else
    (format #f "~A@~A~A> " (language-name (repl-language repl))
            (module-name (current-module))
            (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)) (repl-inport repl)
                                          (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-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 ((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
        ;; a given language, not the result of evaluation.
	(write val (repl-outport repl))
	(newline (repl-outport repl)))))

(define (repl-option-ref repl key)
  (cadr (or (assq key (repl-options repl))
            (error "unknown repl option" key))))

(define (repl-option-set! 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)
  (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 prompt))

;;;
;;; Utilities
;;;

(define (puts x) (display x) (newline))

(define (->string x)
  (object->string x display))

(define (user-error msg . args)
  (throw 'user-error #f msg args #f))

license: mit


code:
;;; Guile VM debugging facilities

;;; Copyright (C) 2001, 2009, 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system repl debug)
  #:use-module (system base pmatch)
  #:use-module (system base syntax)
  #:use-module (system base language)
  #:use-module (system vm vm)
  #:use-module (system vm frame)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 format)
  #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
  #:use-module (system vm program)
  #:export (<debug>
            make-debug debug? debug-frames debug-index
            print-locals print-frame print-frames frame->module
            stack->vector narrow-stack->vector))

;; TODO:
;;
;; Update this TODO list ;)
;; partial meta-commands  (,qui -> ,quit)
;; eval expression in context of frame
;; set local variable in frame
;; step until next instruction
;; step until next function call/return
;; step until return from frame
;; step until different source line
;; step until greater source line
;; watch expression
;; break on a function
;; remove breakpoints
;; set printing width
;; display a truncated backtrace
;; go to a frame by index
;; (reuse gdb commands perhaps)
;; disassemble a function
;; disassemble the current function
;; inspect any object
;; hm, trace via reassigning global vars. tricksy.
;; (state associated with vm ?)

;;;
;;; Debugger
;;;
;;; The actual interaction loop of the debugger is run by the repl. This module
;;; simply exports a data structure to hold the debugger state, along with its
;;; accessors, and provides some helper functions.
;;;

(define-record <debug> frames index)

(define (reverse-hashq h)
  (let ((ret (make-hash-table)))
    (hash-for-each
     (lambda (k v)
       (hashq-set! ret v (cons k (hashq-ref ret v '()))))
     h)
    ret))

(define* (print-locals frame #:optional (port (current-output-port))
                       #:key (width 72) (per-line-prefix "  "))
  (let ((bindings (frame-bindings frame)))
    (cond
     ((null? bindings)
      (format port "~aNo local variables.~%" per-line-prefix))
     (else
      (format port "~aLocal variables:~%" per-line-prefix)
      (for-each
       (lambda (binding)
         (let ((v (let ((x (frame-local-ref frame (binding:index binding))))
                    (if (binding:boxed? binding)
                        (variable-ref x)
                        x))))
           (display per-line-prefix port)
           (run-hook before-print-hook v)
           (format port "~a~:[~; (boxed)~] = ~v:@y\n"
                   (binding:name binding) (binding:boxed? binding) width v)))
       (frame-bindings frame))))))

(define* (print-frame frame #:optional (port (current-output-port))
                      #:key index (width 72) (full? #f) (last-source #f))
  (define (source:pretty-file source)
    (if source
        (or (source:file source) "current input")
        "unknown file"))
  (let* ((source (frame-source frame))
         (file (source:pretty-file source))
         (line (and=> source source:line))
         (col (and=> source source:column)))
    (if (and file (not (equal? file (source:pretty-file last-source))))
        (format port "~&In ~a:~&" file))
    (format port "~9@a~:[~*~3_~;~3d~] ~v:@y~%"
            (if line (format #f "~a:~a" line col) "")
            index index width (frame-call-representation frame))
    (if full?
        (print-locals frame #:width width
                      #:per-line-prefix "     "))))

(define* (print-frames frames
                       #:optional (port (current-output-port))
                       #:key (width 72) (full? #f) (forward? #f) count)
  (let* ((len (vector-length frames))
         (lower-idx (if (or (not count) (positive? count))
                        0
                        (max 0 (+ len count))))
         (upper-idx (if (and count (negative? count))
                        (1- len)
                        (1- (if count (min count len) len))))
         (inc (if forward? 1 -1)))
    (let lp ((i (if forward? lower-idx upper-idx))
             (last-source #f))
      (if (<= lower-idx i upper-idx)
          (let* ((frame (vector-ref frames i)))
            (print-frame frame port #:index i #:width width #:full? full?
                         #:last-source last-source)
            (lp (+ i inc) (frame-source frame)))))))

;; Ideally here we would have something much more syntactic, in that a set! to a
;; local var that is not settable would raise an error, and export etc forms
;; would modify the module in question: but alack, this is what we have now.
;; Patches welcome!
(define (frame->module frame)
  (let ((proc (frame-procedure frame)))
    (if (program? proc)
        (let* ((mod (or (program-module proc) (current-module)))
               (mod* (make-module)))
          (module-use! mod* mod)
          (for-each
           (lambda (binding)
             (let* ((x (frame-local-ref frame (binding:index binding)))
                    (var (if (binding:boxed? binding) x (make-variable x))))
               (format #t
                       "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
                       (binding:boxed? binding)
                       (binding:name binding)
                       (if (variable-bound? var) (variable-ref var) var))
               (module-add! mod* (binding:name binding) var)))
           (frame-bindings frame))
          mod*)
        (current-module))))

;; TODO:
;;
;; eval expression in context of frame
;; set local variable in frame
;; step until next instruction
;; step until next function call/return
;; step until return from frame
;; step until different source line
;; step until greater source line
;; watch expression
;; break on a function
;; remove breakpoints
;; set printing width
;; display a truncated backtrace
;; go to a frame by index
;; (reuse gdb commands perhaps)
;; disassemble a function
;; disassemble the current function
;; inspect any object
;; hm, trace via reassigning global vars. tricksy.
;; (state associated with vm ?)

(define (stack->vector stack)
  (let* ((len (stack-length stack))
         (v (make-vector len)))
    (if (positive? len)
        (let lp ((i 0) (frame (stack-ref stack 0)))
          (if (< i len)
              (begin
                (vector-set! v i frame)
                (lp (1+ i) (frame-previous frame))))))
    v))

(define (narrow-stack->vector stack . args)
  (let ((narrowed (apply make-stack (stack-ref stack 0) args)))
    (if narrowed
        (stack->vector narrowed)
        #()))) ; ? Can be the case for a tail-call to `throw' tho

;; (define (debug)
;;   (run-debugger
;;    (narrow-stack->vector
;;     (make-stack #t)
;;     ;; Narrow the `make-stack' frame and the `debug' frame
;;     2
;;     ;; Narrow the end of the stack to the most recent start-stack.
;;     (and (pair? (fluid-ref %stacks))
;;          (cdar (fluid-ref %stacks))))))


code:
;;; Describe objects

;; Copyright (C) 2001, 2009 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system repl describe)
  #:use-module (oop goops)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 format)
  #:use-module (ice-9 and-let-star)
  #:export (describe))

(define-method (describe (symbol <symbol>))
  (format #t "`~s' is " symbol)
  (if (not (defined? symbol))
      (display "not defined in the current module.\n")
      (describe-object (module-ref (current-module) symbol))))

;;;
;;; Display functions
;;;

(define (safe-class-name class)
  (if (slot-bound? class 'name)
      (class-name class)
      class))

(define-method (display-class class . args)
  (let* ((name (safe-class-name class))
	 (desc (if (pair? args) (car args) name)))
    (if (eq? *describe-format* 'tag)
	(format #t "@class{~a}{~a}" name desc)
	(format #t "~a" desc))))

(define (display-list title list)
  (if title (begin (display title) (display ":\n\n")))
  (if (null? list)
      (display "(not defined)\n")
      (for-each display-summary list)))

(define (display-slot-list title instance list)
  (if title (begin (display title) (display ":\n\n")))
  (if (null? list)
      (display "(not defined)\n")
      (for-each (lambda (slot)
		  (let ((name (slot-definition-name slot)))
		    (display "Slot: ")
		    (display name)
		    (if (and instance (slot-bound? instance name))
			(begin
			  (display " = ")
			  (display (slot-ref instance name))))
		    (newline)))
		list)))

(define (display-file location)
  (display "Defined in ")
  (if (eq? *describe-format* 'tag)
      (format #t "@location{~a}.\n" location)
      (format #t "`~a'.\n" location)))

(define (format-documentation doc)
  (with-current-buffer (make-buffer #:text doc)
    (lambda ()
      (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
	(do-while (match (re-search-forward regexp))
	  (let ((key (string->symbol (match:substring match 1)))
		(value (match:substring match 3)))
	    (case key
	      ((deffnx)
	       (delete-region! (match:start match)
			       (begin (forward-line) (point))))
	      ((var)
	       (replace-match! match 0 (string-upcase value)))
	      ((code)
	       (replace-match! match 0 (string-append "`" value "'")))))))
      (display (string (current-buffer)))
      (newline))))

;;;
;;; Top
;;;

(define description-table
  (list
   (cons <boolean>   "a boolean")
   (cons <null>      "an empty list")
   (cons <integer>   "an integer")
   (cons <real>      "a real number")
   (cons <complex>   "a complex number")
   (cons <char>      "a character")
   (cons <symbol>    "a symbol")
   (cons <keyword>   "a keyword")
   (cons <promise>   "a promise")
   (cons <hook>      "a hook")
   (cons <fluid>     "a fluid")
   (cons <stack>     "a stack")
   (cons <variable>  "a variable")
   (cons <regexp>    "a regexp object")
   (cons <module>    "a module object")
   (cons <unknown>   "an unknown object")))

(define-generic describe-object)
(export describe-object)

(define-method (describe-object (obj <top>))
  (display-type obj)
  (display-location obj)
  (newline)
  (display-value obj)
  (newline)
  (display-documentation obj))

(define-generic display-object)
(define-generic display-summary)
(define-generic display-type)
(define-generic display-value)
(define-generic display-location)
(define-generic display-description)
(define-generic display-documentation)
(export display-object display-summary display-type display-value
	display-location display-description display-documentation)

(define-method (display-object (obj <top>))
  (write obj))

(define-method (display-summary (obj <top>))
  (display "Value: ")
  (display-object obj)
  (newline))

(define-method (display-type (obj <top>))
  (cond
   ((eof-object? obj) (display "the end-of-file object"))
   ((unspecified? obj) (display "unspecified"))
   (else (let ((class (class-of obj)))
	   (display-class class (or (assq-ref description-table class)
				    (safe-class-name class))))))
  (display ".\n"))

(define-method (display-value (obj <top>))
  (if (not (unspecified? obj))
      (begin (display-object obj) (newline))))

(define-method (display-location (obj <top>))
  *unspecified*)

(define-method (display-description (obj <top>))
  (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
	 (index (string-index doc #\newline)))
    (display (make-shared-substring doc 0 (1+ index)))))

(define-method (display-documentation (obj <top>))
  (display "Not documented.\n"))

;;;
;;; Pairs
;;;

(define-method (display-type (obj <pair>))
  (cond
   ((list? obj) (display-class <list> "a list"))
   ((pair? (cdr obj)) (display "an improper list"))
   (else (display-class <pair> "a pair")))
  (display ".\n"))

;;;
;;; Strings
;;;

(define-method (display-type (obj <string>))
  (if (read-only-string? 'obj)
      (display "a read-only string")
      (display-class <string> "a string"))
  (display ".\n"))

;;;
;;; Procedures
;;;

(define-method (display-object (obj <procedure>))
  (cond
   ;; FIXME: VM programs, ...
   (else
    ;; Primitive procedure.  Let's lookup the dictionary.
    (and-let* ((entry (lookup-procedure obj)))
      (let ((name (entry-property entry 'name))
	    (print-arg (lambda (arg)
			 (display " ")
			 (display (string-upcase (symbol->string arg))))))
	(display "(")
	(display name)
	(and-let* ((args (entry-property entry 'args)))
	  (for-each print-arg args))
	(and-let* ((opts (entry-property entry 'opts)))
	  (display " &optional")
	  (for-each print-arg opts))
	(and-let* ((rest (entry-property entry 'rest)))
	  (display " &rest")
	  (print-arg rest))
	(display ")"))))))

(define-method (display-summary (obj <procedure>))
  (display "Procedure: ")
  (display-object obj)
  (newline)
  (display "  ")
  (display-description obj))

(define-method (display-type (obj <procedure>))
  (cond
   ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
   ((procedure-with-setter? obj)
    (display-class <procedure-with-setter> "a procedure with setter"))
   (else (display-class <procedure> "a procedure")))
  (display ".\n"))

(define-method (display-location (obj <procedure>))
  (and-let* ((entry (lookup-procedure obj)))
    (display-file (entry-file entry))))

(define-method (display-documentation (obj <procedure>))
  (cond ((or (procedure-documentation obj)
             (and=> (lookup-procedure obj) entry-text))
	 => format-documentation)
	(else (next-method))))

;;;
;;; Classes
;;;

(define-method (describe-object (obj <class>))
  (display-type obj)
  (display-location obj)
  (newline)
  (display-documentation obj)
  (newline)
  (display-value obj))

(define-method (display-summary (obj <class>))
  (display "Class: ")
  (display-class obj)
  (newline)
  (display "  ")
  (display-description obj))

(define-method (display-type (obj <class>))
  (display-class <class> "a class")
  (if (not (eq? (class-of obj) <class>))
      (begin (display " of ") (display-class (class-of obj))))
  (display ".\n"))

(define-method (display-value (obj <class>))
  (display-list "Class precedence list" (class-precedence-list obj))
  (newline)
  (display-list "Direct superclasses" (class-direct-supers obj))
  (newline)
  (display-list "Direct subclasses" (class-direct-subclasses obj))
  (newline)
  (display-slot-list "Direct slots" #f (class-direct-slots obj))
  (newline)
  (display-list "Direct methods" (class-direct-methods obj)))

;;;
;;; Instances
;;;

(define-method (display-type (obj <object>))
  (display-class <object> "an instance")
  (display " of class ")
  (display-class (class-of obj))
  (display ".\n"))

(define-method (display-value (obj <object>))
  (display-slot-list #f obj (class-slots (class-of obj))))

;;;
;;; Generic functions
;;;

(define-method (display-type (obj <generic>))
  (display-class <generic> "a generic function")
  (display " of class ")
  (display-class (class-of obj))
  (display ".\n"))

(define-method (display-value (obj <generic>))
  (display-list #f (generic-function-methods obj)))

;;;
;;; Methods
;;;

(define-method (display-object (obj <method>))
  (display "(")
  (let ((gf (method-generic-function obj)))
    (display (if gf (generic-function-name gf) "#<anonymous>")))
  (let loop ((args (method-specializers obj)))
    (cond
     ((null? args))
     ((pair? args)
      (display " ")
      (display-class (car args))
      (loop (cdr args)))
     (else (display " . ") (display-class args))))
  (display ")"))

(define-method (display-summary (obj <method>))
  (display "Method: ")
  (display-object obj)
  (newline)
  (display "  ")
  (display-description obj))

(define-method (display-type (obj <method>))
  (display-class <method> "a method")
  (display " of class ")
  (display-class (class-of obj))
  (display ".\n"))

(define-method (display-documentation (obj <method>))
  (let ((doc (procedure-documentation (method-procedure obj))))
    (if doc (format-documentation doc) (next-method))))


code:
;;; Error handling in the REPL

;; Copyright (C) 2001, 2009, 2010 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
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA

;;; Code:

(define-module (system repl error-handling)
  #:use-module (system base pmatch)
  #:use-module (system repl debug)
  #:export (call-with-error-handling
            with-error-handling))

;;;
;;; Error handling via repl debugging
;;;

(define* (call-with-error-handling thunk #:key
                                   (on-error 'debug) (post-error 'catch)
                                   (pass-keys '(quit)))
  (let ((in (current-input-port))
        (out (current-output-port))
        (err (current-error-port)))
    (define (with-saved-ports thunk)
      (with-input-from-port in
        (lambda ()
          (with-output-to-port out
            (lambda ()
              (with-error-to-port err
                thunk))))))

    (catch #t
      (lambda () (%start-stack #t thunk))

      (case post-error
        ((report)
         (lambda (key . args)
           (if (memq key pass-keys)
               (apply throw key args)
               (begin
                 (pmatch args
                  ((,subr ,msg ,args . ,rest)
                   (with-saved-ports
                    (lambda ()
                      (run-hook before-error-hook)
                      (display-error #f err subr msg args rest)
                      (run-hook after-error-hook)
                      (force-output err))))
                  (else
                   (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
                           key args)))
                 (if #f #f)))))
        ((catch)
         (lambda (key . args)
           (if (memq key pass-keys)
               (apply throw key args))))
        (else
         (if (procedure? post-error)
             post-error ; a handler proc
             (error "Unknown post-error strategy" post-error))))

      (case on-error
        ((debug)
         (lambda (key . args)
           (let* ((tag (and (pair? (fluid-ref %stacks))
                            (cdar (fluid-ref %stacks))))
                  (stack (narrow-stack->vector
                          (make-stack #t)
                          ;; Cut three frames from the top of the stack:
                          ;; make-stack, this one, and the throw handler.
                          3
                          ;; Narrow the end of the stack to the most recent
                          ;; start-stack.
                          tag
                          ;; And one more frame, because %start-stack invoking
                          ;; the start-stack thunk has its own frame too.
                          0 (and tag 1)))
                  (debug (make-debug stack 0)))
             (with-saved-ports
              (lambda ()
                (pmatch args
                  ((,subr ,msg ,args . ,rest)
                   (display-error (vector-ref stack 0) (current-output-port)
                                  subr msg args rest))
                  (else
                   (format #t "Throw to key `~a' with args `~s'." key args)))
                (format #t "Entering a new prompt.  ")
                (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
                ((@ (system repl repl) start-repl) #:debug debug))))))
        ((pass)
         (lambda (key . args)
           ;; fall through to rethrow
           #t))
        (else
         (if (procedure? on-error)
             on-error ; pre-unwind handler
             (error "Unknown on-error strategy" on-error)))))))

(define-syntax with-error-handling
  (syntax-rules ()
    ((_ form)
     (call-with-error-handling (lambda () form)))))


code:
;;; Read-Eval-Print Loop

;; Copyright (C) 2001, 2009, 2010 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
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA

;;; Code:

(define-module (system repl repl)
  #:use-module (system base syntax)
  #:use-module (system base pmatch)
  #:use-module (system base compile)
  #:use-module (system base language)
  #:use-module (system vm vm)
  #:use-module (system repl error-handling)
  #:use-module (system repl common)
  #:use-module (system repl command)
  #:use-module (ice-9 control)
  #:export (start-repl run-repl))

;;;
;;; Meta commands
;;;

(define meta-command-token (cons 'meta 'command))

(define (meta-reader read env)
  (lambda read-args
    (let ((port (if (pair? read-args) (car read-args) (current-input-port))))
      (with-input-from-port port
        (lambda ()
          (let ((ch (next-char #t)))
            (cond ((eof-object? ch)
                   ;; apparently sometimes even if this is eof, read will
                   ;; wait on somethingorother. strange.
                   ch)
                  ((eqv? ch #\,)
                   (read-char port)
                   meta-command-token)
                  (else (read port env)))))))))

;; repl-reader is a function defined in boot-9.scm, and is replaced by
;; something else if readline has been activated. much of this hoopla is
;; to be able to re-use the existing readline machinery.
;;
;; Catches read errors, returning *unspecified* in that case.
(define (prompting-meta-read repl)
  (catch #t
    (lambda ()
      (repl-reader (lambda () (repl-prompt repl))
                   (meta-reader (language-reader (repl-language repl))
                                (current-module))))
    (lambda (key . args)
      (case key
        ((quit)
         (apply throw key args))
        (else
         (pmatch args
           ((,subr ,msg ,args . ,rest)
            (format #t "Throw to key `~a' while reading expression:\n" key)
            (display-error #f (current-output-port) subr msg args rest))
           (else
            (format #t "Throw to key `~a' with args `~s' while reading expression.\n"
                    key args)))
         (force-output)
         *unspecified*)))))

;;;
;;; The repl
;;;

(define* (start-repl #:optional (lang (current-language)) #:key debug)
  (run-repl (make-repl lang debug)))

;; (put 'abort-on-error 'scheme-indent-function 1)
(define-syntax abort-on-error
  (syntax-rules ()
    ((_ string exp)
     (catch #t
       (lambda () exp)
       (lambda (key . args)
         (format #t "While ~A:~%" string)
         (pmatch args
           ((,subr ,msg ,args . ,rest)
            (display-error #f (current-output-port) subr msg args rest))
           (else
            (format #t "ERROR: Throw to key `~a' with args `~s'.\n" key args)))
         (force-output)
         (abort))))))

(define (run-repl repl)
  (define (with-stack-and-prompt thunk)
    (call-with-prompt (default-prompt-tag)
                      (lambda () (start-stack #t (thunk)))
                      (lambda (k proc)
                        (with-stack-and-prompt (lambda () (proc k))))))

  (% (with-fluids ((*repl-stack*
                    (cons repl (or (fluid-ref *repl-stack*) '()))))
       (if (null? (cdr (fluid-ref *repl-stack*)))
           (repl-welcome repl))
       (let prompt-loop ()
         (let ((exp (prompting-meta-read repl)))
           (cond
            ((eqv? exp *unspecified*))  ; read error, pass
            ((eq? exp meta-command-token)
             (catch #t
               (lambda ()
                 (meta-command repl))
               (lambda (k . args)
                 (if (eq? k 'quit)
                     (abort args)
                     (begin
                       (format #t "While executing meta-command:~%" string)
                       (pmatch args
                         ((,subr ,msg ,args . ,rest)
                          (display-error #f (current-output-port) subr msg args rest))
                         (else
                          (format #t "ERROR: Throw to key `~a' with args `~s'.\n" key args)))
                       (force-output))))))
            ((eof-object? exp)
             (newline)
             (abort '()))
            (else
             ;; since the input port is line-buffered, consume up to the
             ;; newline
             (flush-to-newline)
             (call-with-error-handling
              (lambda ()
                (catch 'quit
                  (lambda ()
                    (call-with-values
                        (lambda ()
                          (% (let ((thunk
                                    (abort-on-error "compiling expression"
                                      (repl-prepare-eval-thunk
                                       repl
                                       (abort-on-error "parsing expression"
                                         (repl-parse repl exp))))))
                               (run-hook before-eval-hook exp)
                               (with-error-handling
                                 (with-stack-and-prompt thunk)))
                             (lambda (k) (values))))
                      (lambda l
                        (for-each (lambda (v)
                                    (repl-print repl v))
                                  l))))
                  (lambda (k . args)
                    (abort args)))))))
           (next-char #f) ;; consume trailing whitespace
           (prompt-loop))))
     (lambda (k status)
       status)))

(define (next-char wait)
  (if (or wait (char-ready?))
      (let ((ch (peek-char)))
	(cond ((eof-object? ch) ch)
	      ((char-whitespace? ch) (read-char) (next-char wait))
	      (else ch)))
      #f))

(define (flush-to-newline)
  (if (char-ready?)
      (let ((ch (peek-char)))
        (if (and (not (eof-object? ch)) (char-whitespace? ch))
            (begin
              (read-char)
              (if (not (char=? ch #\newline))
                  (flush-to-newline)))))))


code:
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (system vm coverage)
  #:use-module (system vm vm)
  #:use-module (system vm frame)
  #:use-module (system vm program)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (with-code-coverage
            coverage-data?
            instrumented-source-files
            instrumented/executed-lines
            line-execution-counts
            procedure-execution-count
            coverage-data->lcov))

;;; Author: Ludovic Courtès
;;;
;;; Commentary:
;;;
;;; This module provides support to gather code coverage data by instrumenting
;;; the VM.
;;;
;;; Code:

;;;
;;; Gathering coverage data.
;;;

(define (hashq-proc proc n)
  ;; Return the hash of PROC's objcode.
  (hashq (program-objcode proc) n))

(define (assq-proc proc alist)
  ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
  ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
  ;; are taken as an arbitrary representative of all the procedures (closures)
  ;; sharing that objcode.  This can significantly reduce memory consumption.
  (let ((code (program-objcode proc)))
    (find (lambda (pair)
            (eq? code (program-objcode (car pair))))
          alist)))

(define (with-code-coverage vm thunk)
  "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
coverage data.  Return code coverage data and the values returned by THUNK."

  (define procedure->ip-counts
    ;; Mapping from procedures to hash tables; said hash tables map instruction
    ;; pointers to the number of times they were executed.
    (make-hash-table 500))

  (define (collect! frame)
    ;; Update PROCEDURE->IP-COUNTS with info from FRAME.
    (let* ((proc       (frame-procedure frame))
           (ip         (frame-instruction-pointer frame))
           (proc-entry (hashx-create-handle! hashq-proc assq-proc
                                             procedure->ip-counts proc #f)))
      (let loop ()
        (define ip-counts (cdr proc-entry))
        (if ip-counts
            (let ((ip-entry (hashv-create-handle! ip-counts ip 0)))
              (set-cdr! ip-entry (+ (cdr ip-entry) 1)))
            (begin
              (set-cdr! proc-entry (make-hash-table))
              (loop))))))

  (call-with-values (lambda ()
                      (let ((level (vm-trace-level vm))
                            (hook  (vm-next-hook vm)))
                        (dynamic-wind
                          (lambda ()
                            (set-vm-trace-level! vm (+ level 1))
                            (add-hook! hook collect!))
                          (lambda ()
                            (vm-apply vm thunk '()))
                          (lambda ()
                            (set-vm-trace-level! vm level)
                            (remove-hook! hook collect!)))))
    (lambda args
      (apply values (make-coverage-data procedure->ip-counts) args))))

;;;
;;; Coverage data summary.
;;;

(define-record-type <coverage-data>
  (%make-coverage-data procedure->ip-counts
                       procedure->sources
                       file->procedures
                       file->line-counts)
  coverage-data?

  ;; Mapping from procedures to hash tables; said hash tables map instruction
  ;; pointers to the number of times they were executed.
  (procedure->ip-counts data-procedure->ip-counts)

  ;; Mapping from procedures to the result of `program-sources'.
  (procedure->sources   data-procedure->sources)

  ;; Mapping from source file names to lists of procedures defined in the file.
  (file->procedures     data-file->procedures)

  ;; Mapping from file names to hash tables, which in turn map from line numbers
  ;; to execution counts.
  (file->line-counts    data-file->line-counts))

(define (make-coverage-data procedure->ip-counts)
  ;; Return a `coverage-data' object based on the coverage data available in
  ;; PROCEDURE->IP-COUNTS.  Precompute the other hash tables that make up
  ;; `coverage-data' objects.
  (let* ((procedure->sources (make-hash-table 500))
         (file->procedures   (make-hash-table 100))
         (file->line-counts  (make-hash-table 100))
         (data               (%make-coverage-data procedure->ip-counts
                                                  procedure->sources
                                                  file->procedures
                                                  file->line-counts)))
    (define (increment-execution-count! file line count)
      ;; Make the execution count of FILE:LINE the maximum of its current value
      ;; and COUNT.  This is so that LINE's execution count is correct when
      ;; several instruction pointers map to LINE.
      (let ((file-entry (hash-create-handle! file->line-counts file #f)))
        (if (not (cdr file-entry))
            (set-cdr! file-entry (make-hash-table 500)))
        (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
          (set-cdr! line-entry (max (cdr line-entry) count)))))

    ;; Update execution counts for procs that were executed.
    (hash-for-each (lambda (proc ip-counts)
                     (let* ((sources (program-sources* data proc))
                            (file    (and (pair? sources)
                                          (source:file (car sources)))))
                       (and file
                            (begin
                              ;; Add a zero count for all IPs in SOURCES and in
                              ;; the sources of procedures closed over by PROC.
                              (for-each
                               (lambda (source)
                                 (let ((file (source:file source))
                                       (line (source:line source)))
                                   (increment-execution-count! file line 0)))
                               (append-map (cut program-sources* data <>)
                                           (closed-over-procedures proc)))

                              ;; Add the actual execution count collected.
                              (hash-for-each
                               (lambda (ip count)
                                 (let ((line (closest-source-line sources ip)))
                                   (increment-execution-count! file line count)))
                               ip-counts)))))
                   procedure->ip-counts)

    ;; Set the execution count to zero for procedures loaded and not executed.
    ;; FIXME: Traversing thousands of procedures here is inefficient.
    (for-each (lambda (proc)
                (and (not (hashq-ref procedure->sources proc))
                     (for-each (lambda (proc)
                                 (let* ((sources (program-sources* data proc))
                                        (file    (and (pair? sources)
                                                      (source:file (car sources)))))
                                   (and file
                                        (for-each
                                         (lambda (ip)
                                           (let ((line (closest-source-line sources ip)))
                                             (increment-execution-count! file line 0)))
                                         (map source:addr sources)))))
                               (closed-over-procedures proc))))
              (append-map module-procedures (loaded-modules)))

    data))

(define (procedure-execution-count data proc)
  "Return the number of times PROC's code was executed, according to DATA, or #f
if PROC was not executed.  When PROC is a closure, the number of times its code
was executed is returned, not the number of times this code associated with this
particular closure was executed."
  (and=> (hashx-ref hashq-proc assq-proc
                    (data-procedure->ip-counts data) proc)
         (let ((sources (program-sources* data proc)))
           (lambda (ip-counts)
             (let ((entry-ip (source:addr (car sources)))) ;; FIXME: broken with lambda*
               (hashv-ref ip-counts entry-ip 0))))))

(define (program-sources* data proc)
  ;; A memoizing version of `program-sources'.
  (or (hashq-ref (data-procedure->sources data) proc)
      (and (program? proc)
           (let ((sources (program-sources proc))
                 (p->s    (data-procedure->sources data))
                 (f->p    (data-file->procedures data)))
             (if (pair? sources)
                 (let* ((file  (source:file (car sources)))
                        (entry (hash-create-handle! f->p file '())))
                   (hashq-set! p->s proc sources)
                   (set-cdr! entry (cons proc (cdr entry)))
                   sources)
                 sources)))))

(define (file-procedures data file)
  ;; Return the list of globally bound procedures defined in FILE.
  (hash-ref (data-file->procedures data) file '()))

(define (instrumented/executed-lines data file)
  "Return the number of instrumented and the number of executed source lines in
FILE according to DATA."
  (define instr+exec
    (and=> (hash-ref (data-file->line-counts data) file)
           (lambda (line-counts)
             (hash-fold (lambda (line count instr+exec)
                          (let ((instr (car instr+exec))
                                (exec  (cdr instr+exec)))
                            (cons (+ 1 instr)
                                  (if (> count 0)
                                      (+ 1 exec)
                                      exec))))
                        '(0 . 0)
                        line-counts))))

  (values (car instr+exec) (cdr instr+exec)))

(define (line-execution-counts data file)
  "Return a list of line number/execution count pairs for FILE, or #f if FILE
is not among the files covered by DATA."
  (and=> (hash-ref (data-file->line-counts data) file)
         (lambda (line-counts)
           (hash-fold alist-cons '() line-counts))))

(define (instrumented-source-files data)
  "Return the list of `instrumented' source files, i.e., source files whose code
was loaded at the time DATA was collected."
  (hash-fold (lambda (file counts files)
               (cons file files))
             '()
             (data-file->line-counts data)))

;;;
;;; Helpers.
;;;

(define (loaded-modules)
  ;; Return the list of all the modules currently loaded.
  (define seen (make-hash-table))

  (let loop ((modules (module-submodules (resolve-module '() #f)))
             (result  '()))
    (hash-fold (lambda (name module result)
                 (if (hashq-ref seen module)
                     result
                     (begin
                       (hashq-set! seen module #t)
                       (loop (module-submodules module)
                             (cons module result)))))
               result
               modules)))

(define (module-procedures module)
  ;; Return the list of procedures bound globally in MODULE.
  (hash-fold (lambda (binding var result)
               (if (variable-bound? var)
                   (let ((value (variable-ref var)))
                     (if (procedure? value)
                         (cons value result)
                         result))
                   result))
             '()
             (module-obarray module)))

(define (closest-source-line sources ip)
  ;; Given SOURCES, as returned by `program-sources' for a given procedure,
  ;; return the source line of code that is the closest to IP.  This is similar
  ;; to what `program-source' does.
  (let loop ((sources sources)
             (line    (and (pair? sources) (source:line (car sources)))))
    (if (null? sources)
        line
        (let ((source (car sources)))
          (if (> (source:addr source) ip)
              line
              (loop (cdr sources) (source:line source)))))))

(define (closed-over-procedures proc)
  ;; Return the list of procedures PROC closes over, PROC included.
  (let loop ((proc   proc)
             (result '()))
    (if (and (program? proc) (not (memq proc result)))
        (fold loop (cons proc result)
              (append (vector->list (or (program-objects proc) #()))
                      (program-free-variables proc)))
        result)))

;;;
;;; LCOV output.
;;;

(define* (coverage-data->lcov data port)
  "Traverse code coverage information DATA, as obtained with
`with-code-coverage', and write coverage information in the LCOV format to PORT.
The report will include all the modules loaded at the time coverage data was
gathered, even if their code was not executed."

  (define (dump-function proc)
    ;; Dump source location and basic coverage data for PROC.
    (and (program? proc)
         (let ((sources (program-sources* data proc)))
           (and (pair? sources)
                (let* ((line (source:line (car sources)))
                       (name (or (procedure-name proc)
                                 (format #f "anonymous-l~a" (+ 1 line)))))
                  (format port "FN:~A,~A~%" (+ 1 line) name)
                  (and=> (procedure-execution-count data proc)
                         (lambda (count)
                           (format port "FNDA:~A,~A~%" count name))))))))

  ;; Output per-file coverage data.
  (format port "TN:~%")
  (for-each (lambda (file)
              (let ((procs (file-procedures data file))
                    (path  (search-path %load-path file)))
                (if (string? path)
                    (begin
                      (format port "SF:~A~%" path)
                      (for-each dump-function procs)
                      (for-each (lambda (line+count)
                                  (let ((line  (car line+count))
                                        (count (cdr line+count)))
                                    (format port "DA:~A,~A~%"
                                            (+ 1 line) count)))
                                (line-execution-counts data file))
                      (let-values (((instr exec)
                                    (instrumented/executed-lines data file)))
                        (format port "LH: ~A~%" exec)
                        (format port "LF: ~A~%" instr))
                      (format port "end_of_record~%"))
                    (begin
                      (format (current-error-port)
                              "skipping unknown source file: ~a~%"
                              file)))))
            (instrumented-source-files data)))


code:
;;; Guile VM frame functions

;;; Copyright (C) 2001, 2005, 2009, 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system vm frame)
  #:use-module (system base pmatch)
  #:use-module (system vm program)
  #:use-module (system vm instruction)
  #:use-module (system vm objcode)
  #:use-module ((srfi srfi-1) #:select (fold))
  #:export (frame-bindings
            frame-lookup-binding
            frame-binding-ref frame-binding-set!
            frame-source frame-call-representation
            frame-environment
            frame-object-binding frame-object-name))

(define (frame-bindings frame)
  (program-bindings-for-ip (frame-procedure frame)
                           (frame-instruction-pointer frame)))

(define (frame-lookup-binding frame var)
  (let lp ((bindings (frame-bindings frame)))
    (cond ((null? bindings)
           #f)
          ((eq? (binding:name (car bindings)) var)
           (car bindings))
          (else
           (lp (cdr bindings))))))

(define (frame-binding-set! frame var val)
  (frame-local-set! frame
                    (binding:index
                     (or (frame-lookup-binding frame var)
                         (error "variable not bound in frame" var frame)))
                    val))

(define (frame-binding-ref frame var)
  (frame-local-ref frame
                   (binding:index
                    (or (frame-lookup-binding frame var)
                        (error "variable not bound in frame" var frame)))))

;; This function is always called to get some sort of representation of the
;; frame to present to the user, so let's do the logical thing and dispatch to
;; frame-call-representation.
(define (frame-arguments frame)
  (cdr (frame-call-representation frame)))

;;;
;;; Pretty printing
;;;

(define (frame-source frame)
  (program-source (frame-procedure frame)
                  (frame-instruction-pointer frame)))

;; Basically there are two cases to deal with here:
;;
;;   1. We've already parsed the arguments, and bound them to local
;;      variables. In a standard (lambda (a b c) ...) call, this doesn't
;;      involve any argument shuffling; but with rest, optional, or
;;      keyword arguments, the arguments as given to the procedure may
;;      not correspond to what's on the stack. We reconstruct the
;;      arguments using e.g. for the case above: `(,a ,b ,c). This works
;;      for rest arguments too: (a b . c) => `(,a ,b . ,c)
;;
;;   2. We have failed to parse the arguments. Perhaps it's the wrong
;;      number of arguments, or perhaps we're doing a typed dispatch and
;;      the types don't match. In that case the arguments are all on the
;;      stack, and nothing else is on the stack.

(define (frame-call-representation frame)
  (let ((p (frame-procedure frame)))
    (cons
     (or (procedure-name p) p)
     (cond
      ((program-arguments-alist p (frame-instruction-pointer frame))
       ;; case 1
       => (lambda (arguments)
            (define (binding-ref sym i)
              (cond
               ((frame-lookup-binding frame sym)
                => (lambda (b) (frame-local-ref frame (binding:index b))))
               ((< i (frame-num-locals frame))
                (frame-local-ref frame i))
               (else
                ;; let's not error here, as we are called during backtraces...
                '???)))
            (let lp ((req (or (assq-ref arguments 'required) '()))
                     (opt (or (assq-ref arguments 'optional) '()))
                     (key (or (assq-ref arguments 'keyword) '()))
                     (rest (or (assq-ref arguments 'rest) #f))
                     (i 0))
              (cond
               ((pair? req)
                (cons (binding-ref (car req) i)
                      (lp (cdr req) opt key rest (1+ i))))
               ((pair? opt)
                (cons (binding-ref (car opt) i)
                      (lp req (cdr opt) key rest (1+ i))))
               ((pair? key)
                (cons* (caar key)
                       (frame-local-ref frame (cdar key))
                       (lp req opt (cdr key) rest (1+ i))))
               (rest
                (binding-ref rest i))
               (else
                '())))))
      (else
       ;; case 2
       (map (lambda (i)
              (frame-local-ref frame i))
            (iota (frame-num-locals frame))))))))

;;; Misc
;;;

(define (frame-environment frame)
  (map (lambda (binding)
	 (cons (binding:name binding) (frame-binding-ref frame binding)))
       (frame-bindings frame)))

(define (frame-object-binding frame obj)
  (do ((bs (frame-bindings frame) (cdr bs)))
      ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
       (and (pair? bs) (car bs)))))

(define (frame-object-name frame obj)
  (cond ((frame-object-binding frame obj) => binding:name)
	(else #f)))


code:
;;; Guile VM debugging facilities

;;; Copyright (C) 2001, 2009, 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system vm inspect)
  #:use-module (system base pmatch)
  #:use-module (system base syntax)
  #:use-module (system vm vm)
  #:use-module (system vm frame)
  #:use-module ((language assembly disassemble)
                #:select ((disassemble . %disassemble)))
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 format)
  #:use-module (system vm program)
  #:export (inspect))

(define (reverse-hashq h)
  (let ((ret (make-hash-table)))
    (hash-for-each
     (lambda (k v)
       (hashq-set! ret v (cons k (hashq-ref ret v '()))))
     h)
    ret))

(define (catch-bad-arguments thunk bad-args-thunk)
  (catch 'wrong-number-of-args
    (lambda ()
      (catch 'keyword-argument-error
        thunk
        (lambda (k . args)
          (bad-args-thunk))))
    (lambda (k . args)
      (bad-args-thunk))))

(define (read-args prompt)
  (define (read* reader)
    (repl-reader prompt reader))
  (define (next)
    (read* read-char))
  (define (cmd chr)
    (cond
     ((eof-object? chr) (list chr))
     ((char=? chr #\newline) (cmd (next)))
     ((char-whitespace? chr) (cmd (next)))
     (else
      (unread-char chr)
      (let ((tok (read* read)))
        (args (list tok) (next))))))
  (define (args out chr)
    (cond
     ((eof-object? chr) (reverse out))
     ((char=? chr #\newline) (reverse out))
     ((char-whitespace? chr) (args out (next)))
     (else
      (unread-char chr)
      (let ((tok (read* read)))
        (args (cons tok out) (next))))))
  (cmd (next)))

;;;
;;; Inspector
;;;

(define (inspect x)
  (define-syntax define-command
    (syntax-rules ()
      ((_ ((mod cname alias ...) . args) body ...)
       (define cname
         (let ((c (lambda* args body ...)))
           (set-procedure-property! c 'name 'cname)
           (module-define! mod 'cname c)
           (module-add! mod 'alias (module-local-variable mod 'cname))
           ...
           c)))))

  (let ((commands (make-module)))
    (define (prompt)
      (format #f "~20@y inspect> " x))

    (define-command ((commands quit q continue cont c))
      "Quit the inspector."
      (throw 'quit))

    (define-command ((commands print p))
      "Print the current object using `pretty-print'."
      (pretty-print x))

    (define-command ((commands write w))
      "Print the current object using `write'."
      (write x))

    (define-command ((commands display d))
      "Print the current object using `display'."
      (display x))

    (define-command ((commands disassemble x))
      "Disassemble the current object, which should be objcode or a procedure."
      (catch #t
        (lambda ()
          (%disassemble x))
        (lambda args
          (format #t "Error disassembling object: ~a\n" args))))

    (define-command ((commands help h ?) #:optional cmd)
      "Show this help message."
      (let ((rhash (reverse-hashq (module-obarray commands))))
        (define (help-cmd cmd)
          (let* ((v (module-local-variable commands cmd))
                 (p (variable-ref v))
                 (canonical-name (procedure-name p)))
            ;; la la la
            (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
                    canonical-name (program-lambda-list p)
                    "~#[~:;~40t(aliases: ~@{~a~^, ~})~]"
                    (delq canonical-name (hashq-ref rhash v))
                    (procedure-documentation p))))
        (cond
         (cmd
          (cond
           ((and (symbol? cmd) (module-local-variable commands cmd))
            (help-cmd cmd))
           (else
            (format #t "Invalid command ~s.~%" cmd)
            (format #t "Try `help' for a list of commands~%"))))
         (else
          (let ((names (sort
                        (hash-map->list
                         (lambda (k v)
                           (procedure-name (variable-ref k)))
                         rhash)
                        (lambda (x y)
                          (string<? (symbol->string x)
                                    (symbol->string y))))))
            (format #t "Available commands:~%~%")
            (for-each help-cmd names))))))

    (define (handle cmd . args)
      (cond
       ((and (symbol? cmd)
             (module-local-variable commands cmd))
        => (lambda (var)
             (let ((proc (variable-ref var)))
               (catch-bad-arguments
                (lambda ()
                  (apply (variable-ref var) args))
                (lambda ()
                  (format (current-error-port)
                          "Invalid arguments to ~a. Try `help ~a'.~%"
                          (procedure-name proc) (procedure-name proc)))))))
       ; ((and (integer? cmd) (exact? cmd))
       ;  (nth cmd))
       ((eof-object? cmd)
        (newline)
        (throw 'quit))
       (else
        (format (current-error-port)
                "~&Unknown command: ~a. Try `help'.~%" cmd)
        *unspecified*)))

    (catch 'quit
      (lambda ()
        (let loop ()
          (apply
           handle
           (save-module-excursion
            (lambda ()
              (set-current-module commands)
              (read-args prompt))))
          (loop)))
      (lambda (k . args)
        (apply values args)))))


code:
;;; Guile VM instructions

;; Copyright (C) 2001, 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system vm instruction)
  #:export (instruction-list
           instruction? instruction-length
           instruction-pops instruction-pushes
           instruction->opcode opcode->instruction))

(load-extension (string-append "libguile-" (effective-version))
                "scm_init_instructions")


code:
;;; Guile VM object code

;; Copyright (C) 2001, 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system vm objcode)
  #:export (objcode? objcode-meta
            bytecode->objcode objcode->bytecode
            load-objcode write-objcode
            word-size byte-order))

(load-extension (string-append "libguile-" (effective-version))
                "scm_init_objcodes")


code:
;;; Guile VM profiler

;; Copyright (C) 2001 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system vm profile)
  #:use-module (system vm vm)
  #:use-module (ice-9 format)
  #:export (vm-profile))

(define (vm-profile vm objcode . opts)
  (let ((flag (vm-option vm 'debug)))
    (dynamic-wind
	(lambda ()
	  (set-vm-option! vm 'debug #t)
	  (set-vm-option! vm 'profile-data '())
	  (add-hook! (vm-next-hook vm) profile-next)
	  (add-hook! (vm-enter-hook vm) profile-enter)
	  (add-hook! (vm-exit-hook vm) profile-exit))
	(lambda ()
	  (vm-load vm objcode)
	  (print-result vm))
	(lambda ()
	  (set-vm-option! vm 'debug flag)
	  (remove-hook! (vm-next-hook vm) profile-next)
	  (remove-hook! (vm-enter-hook vm) profile-enter)
	  (remove-hook! (vm-exit-hook vm) profile-exit)))))

(define (profile-next vm)
  (set-vm-option! vm 'profile-data
		  (cons (vm-fetch-code vm) (vm-option vm 'profile-data))))

(define (profile-enter vm)
  #f)

(define (profile-exit vm)
  #f)

(define (print-result vm . opts)
  (do ((data (vm-option vm 'profile-data) (cdr data))
       (summary '() (let ((inst (caar data)))
		      (assq-set! summary inst
				 (1+ (or (assq-ref summary inst) 0))))))
      ((null? data)
       (display "Count  Instruction\n")
       (display "-----  -----------\n")
       (for-each (lambda (entry)
		   (format #t "~5@A  ~A\n" (cdr entry) (car entry)))
		 (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2))))))))


code:
;;; Guile VM program functions

;;; Copyright (C) 2001, 2009, 2010 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
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system vm program)
  #:use-module (system base pmatch)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (make-program

            make-binding binding:name binding:boxed? binding:index
            binding:start binding:end

            source:addr source:line source:column source:file
            program-sources program-source

            program-bindings program-bindings-by-index program-bindings-for-ip
            program-arities program-arity arity:start arity:end

            arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?

            program-arguments-alist program-lambda-list

            program-meta
            program-objcode program? program-objects
            program-module program-base
            program-free-variables
            program-num-free-variables
            program-free-variable-ref program-free-variable-set!))

(load-extension (string-append "libguile-" (effective-version))
                "scm_init_programs")

(define (make-binding name boxed? index start end)
  (list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
(define (binding:boxed? b) (list-ref b 1))
(define (binding:index b) (list-ref b 2))
(define (binding:start b) (list-ref b 3))
(define (binding:end b) (list-ref b 4))

(define (source:addr source)
  (car source))
(define (source:file source)
  (cadr source))
(define (source:line source)
  (caddr source))
(define (source:column source)
  (cdddr source))

(define (collapse-locals locs)
  (let lp ((ret '()) (locs locs))
    (if (null? locs)
        (map cdr (sort! ret
                        (lambda (x y) (< (car x) (car y)))))
        (let ((b (car locs)))
          (cond
           ((assv-ref ret (binding:index b))
            => (lambda (bindings)
                 (append! bindings (list b))
                 (lp ret (cdr locs))))
           (else
            (lp (acons (binding:index b) (list b) ret)
                (cdr locs))))))))

;; returns list of list of bindings
;; (list-ref ret N) == bindings bound to the Nth local slot
(define (program-bindings-by-index prog)
  (cond ((program-bindings prog) => collapse-locals)
        (else '())))

(define (program-bindings-for-ip prog ip)
  (let lp ((in (program-bindings-by-index prog)) (out '()))
    (if (null? in)
        (reverse out)
        (lp (cdr in)
            (let inner ((binds (car in)))
              (cond ((null? binds) out)
                    ((<= (binding:start (car binds))
                         ip
                         (binding:end (car binds)))
                     (cons (car binds) out))
                    (else (inner (cdr binds)))))))))

(define (arity:start a)
  (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
(define (arity:end a)
  (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
(define (arity:nreq a)
  (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
(define (arity:nopt a)
  (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
(define (arity:rest? a)
  (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
(define (arity:kw a)
  (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
(define (arity:allow-other-keys? a)
  (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))

(define (program-arity prog ip)
  (let ((arities (program-arities prog)))
    (and arities
         (let lp ((arities arities))
           (cond ((null? arities) #f)
                 ((not ip) (car arities)) ; take the first one
                 ((and (< (arity:start (car arities)) ip)
                       (<= ip (arity:end (car arities))))
                  (car arities))
                 (else (lp (cdr arities))))))))

(define (arglist->arguments-alist arglist)
  (pmatch arglist
    ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
     `((required . ,req)
       (optional . ,opt)
       (keyword . ,keyword)
       (allow-other-keys? . ,allow-other-keys?)
       (rest . ,rest)
       (extents . ,extents)))
    (else #f)))

(define* (arity->arguments-alist prog arity
                                 #:optional
                                 (make-placeholder
                                  (lambda (i) (string->symbol "_"))))
  (define var-by-index
    (let ((rbinds (map (lambda (x)
                         (cons (binding:index x) (binding:name x)))
                       (program-bindings-for-ip prog
                                                (arity:start arity)))))
      (lambda (i)
        (or (assv-ref rbinds i)
            ;; if we don't know the name, return a placeholder
            (make-placeholder i)))))

  (let lp ((nreq (arity:nreq arity)) (req '())
           (nopt (arity:nopt arity)) (opt '())
           (rest? (arity:rest? arity)) (rest #f)
           (n 0))
    (cond
     ((< 0 nreq)
      (lp (1- nreq) (cons (var-by-index n) req)
          nopt opt rest? rest (1+ n)))
     ((< 0 nopt)
      (lp nreq req
          (1- nopt) (cons (var-by-index n) opt)
          rest? rest (1+ n)))
     (rest?
      (lp nreq req nopt opt
          #f (var-by-index n)
          (1+ n)))
     (else
      `((required . ,(reverse req))
        (optional . ,(reverse opt))
        (keyword . ,(arity:kw arity))
        (allow-other-keys? . ,(arity:allow-other-keys? arity))
        (rest . ,rest))))))

;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip)
  (let ((arity (program-arity prog ip)))
    (and arity
         (arity->arguments-alist prog arity))))

(define* (program-lambda-list prog #:optional ip)
  (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))

(define (arguments-alist->lambda-list arguments-alist)
  (let ((req (or (assq-ref arguments-alist 'required) '()))
        (opt (or (assq-ref arguments-alist 'optional) '()))
        (key (map keyword->symbol
                  (map car (or (assq-ref arguments-alist 'keyword) '()))))
        (rest (or (assq-ref arguments-alist 'rest) '())))
    `(,@req
      ,@(if (pair? opt) (cons #:optional opt) '())
      ,@(if (pair? key) (cons #:key key) '())
      . ,rest)))

(define (program-free-variables prog)
  "Return the list of free variables of PROG."
  (let ((count (program-num-free-variables prog)))
    (unfold (lambda (i) (>= i count))
            (cut program-free-variable-ref prog <>)
            1+
            0)))

(define (write-program prog port)
  (format port "#<procedure ~a~a>"
          (or (procedure-name prog)
              (and=> (program-source prog 0)
                     (lambda (s)
                       (format #f "~a at ~a:~a:~a"
                               (number->string (object-address prog) 16)
                               (or (source:file s)
                                   (if s "<current input>" "<unknown port>"))
                               (source:line s) (source:column s))))
              (number->string (object-address prog) 16))
          (let ((arities (program-arities prog)))
            (if (or (not arities) (null? arities))
                ""
                (string-append
                 " " (string-join (map (lambda (a)
                                         (object->string
                                          (arguments-alist->lambda-list
                                           (arity->arguments-alist prog a))))
                                       arities)
                                  " | "))))))