mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
dca9a4d685
* module/system/repl/command.scm: Add support for ,show with topics "warranty", "copying", and "version". (language): Don't re-print the welcome; print sometime more terse. * module/system/repl/common.scm (*version*, *warranty*, *copying*): New public globals. (repl-welcome): Display *version*.
509 lines
16 KiB
Scheme
509 lines
16 KiB
Scheme
;;; 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 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 (statprof)
|
||
#:export (meta-command))
|
||
|
||
|
||
;;;
|
||
;;; Meta command interface
|
||
;;;
|
||
|
||
(define *command-table*
|
||
'((help (help h) (show s) (apropos a) (describe d) (option o) (quit q))
|
||
(module (module m) (import i) (load l) (binding b))
|
||
(language (language L))
|
||
(compile (compile c) (compile-file cc)
|
||
(disassemble x) (disassemble-file xx))
|
||
(profile (time t) (profile pr))
|
||
(debug (trace tr))
|
||
(system (gc) (statistics stat))))
|
||
|
||
(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-abbrev c) (if (null? (cdr c)) #f (cadr 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))
|
||
(for-each (lambda (c)
|
||
(display-summary (command-usage c)
|
||
(and abbrev? (command-abbrev c))
|
||
(command-summary c)))
|
||
(group-commands group))
|
||
(newline))
|
||
|
||
(define (display-command command)
|
||
(display "Usage: ")
|
||
(display (command-doc command))
|
||
(newline))
|
||
|
||
(define (display-summary usage abbrev summary)
|
||
(let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
|
||
(format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
|
||
|
||
(define (read-datum repl)
|
||
(read))
|
||
|
||
(define read-line
|
||
(let ((orig-read-line read-line))
|
||
(lambda (repl)
|
||
(orig-read-line))))
|
||
|
||
(define (meta-command repl)
|
||
(let ((command (read-datum repl)))
|
||
(if (not (symbol? command))
|
||
(user-error "Meta-command not a symbol: ~s" command))
|
||
(let ((c (lookup-command command)))
|
||
(if c
|
||
((command-procedure c) repl)
|
||
(user-error "Unknown meta command: ~A" command)))))
|
||
|
||
(define-syntax define-meta-command
|
||
(syntax-rules ()
|
||
((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
|
||
(define (name repl)
|
||
docstring
|
||
(let* ((expression0
|
||
(repl-reader ""
|
||
(lambda args
|
||
(let ((port (if (pair? args)
|
||
(car args)
|
||
(current-input-port))))
|
||
((language-reader (repl-language repl))
|
||
port (current-module))))))
|
||
...)
|
||
(apply (lambda datums b0 b1 ...)
|
||
(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))))))))))
|
||
((_ (name repl . datums) docstring b0 b1 ...)
|
||
(define-meta-command (name repl () . datums)
|
||
docstring b0 b1 ...))))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Help commands
|
||
;;;
|
||
|
||
(define-meta-command (help repl . args)
|
||
"help
|
||
help GROUP
|
||
help [-c] COMMAND
|
||
|
||
Gives help on the meta-commands available at the REPL.
|
||
|
||
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 `,COMMAND -h' to show documentation of each 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)
|
||
(user-error "Unknown command or group: ~A" command))
|
||
((-c ,command)
|
||
(user-error "Unknown command: ~A" command))
|
||
(else
|
||
(user-error "Bad arguments: ~A" args))))
|
||
|
||
(define-meta-command (show repl . args)
|
||
"show
|
||
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)
|
||
(user-error "Unknown topic: ~A" command))
|
||
(else
|
||
(user-error "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 (key+val)
|
||
(format #t "~A\t~A\n" (car key+val) (cdr key+val)))
|
||
(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)
|
||
(user-error "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 . opts)
|
||
"load FILE
|
||
Load a file in the current module.
|
||
|
||
-f Load source file (see `compile')"
|
||
(let ((file (->string file)))
|
||
(if (memq #:f opts)
|
||
(primitive-load file)
|
||
(guile:load 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 "Have fun 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) . opts)
|
||
"compile FORM
|
||
Generate compiled code.
|
||
|
||
-e Stop after expanding syntax/macro
|
||
-t Stop after translating into GHIL
|
||
-c Stop after generating GLIL
|
||
|
||
-O Enable optimization
|
||
-D Add debug information"
|
||
(let ((x (apply repl-compile repl (repl-parse repl form) opts)))
|
||
(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 PROGRAM
|
||
Disassemble a program."
|
||
(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 FORM
|
||
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 FORM
|
||
Profile execution."
|
||
;; FIXME opts
|
||
(apply statprof
|
||
(make-program (repl-compile repl (repl-parse repl form)))
|
||
opts))
|
||
|
||
|
||
|
||
;;;
|
||
;;; Debug commands
|
||
;;;
|
||
|
||
(define-meta-command (trace repl (form) . opts)
|
||
"trace FORM
|
||
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))
|
||
|
||
|
||
|
||
;;;
|
||
;;; 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"))
|