;;; Code:
(define-module (system repl command)
- :use-module (oop goops)
:use-syntax (system base syntax)
- :use-module (system base language)
+ :use-module (system base compile)
:use-module (system repl common)
- :use-module (system il glil)
:use-module (system vm core)
- :use-module (system vm load)
- :use-module (system vm trace)
- :use-module (system vm disasm)
- :use-module (system vm profile)
+ :autoload (system base language) (lookup-language)
+ :autoload (system il glil) (pprint-glil)
+ :autoload (system vm disasm) (disassemble-program disassemble-objcode)
+ :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
+ :autoload (system vm profile) (vm-profile)
+ :autoload (system vm debugger) (vm-debugger)
+ :autoload (system vm backtrace) (vm-backtrace)
:use-module (ice-9 format)
:use-module (ice-9 session)
- :use-module (ice-9 debugger)
- :export (meta-command))
-
-(define (puts x) (display x) (newline))
-
-(define (user-error msg . args)
- (throw 'user-error #f msg args #f))
+ :use-module (ice-9 documentation))
\f
;;;
-;;; Meta command
+;;; Meta command interface
;;;
(define *command-table*
'((help (help h) (apropos a) (describe d) (option o) (quit q))
- (module (module m) (use u) (import i) (load l) (binding b) (lsmod lm))
- (package (package p) (lspkg lp) (autopackage) (globals g))
+ (module (module m) (use u) (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 (backtrace bt) (debugger db) (trace tr) (step st))
- (system (statistics stat) (gc))))
+ (system (gc) (statistics stat))))
(define (group-name g) (car g))
(define (group-commands g) (cdr g))
(let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
(format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
-(define (meta-command repl line)
+(define-public (meta-command repl line)
(let ((input (call-with-input-string (string-append "(" line ")") read)))
(if (not (null? input))
(do ((key (car input))
(if c
(cond ((memq :h opts) (display-command c))
(else (apply (command-procedure c)
- repl (append! args opts))))
+ repl (append! args (reverse! opts)))))
(user-error "Unknown meta command: ~A" key))))))))
\f
(define (help repl . args)
"help [GROUP]
-Show help messages.
-The optional argument can be either one of command groups or
-command names. Without argument, a list of help commands and
-all command groups are displayed, as you have already seen :)"
+List available meta commands.
+A command group name can be given as an optional argument.
+Without any argument, a list of help commands and command groups
+are displayed, as you have already seen ;)"
(match args
(()
(display-group (lookup-group 'help))
(display-summary usage #f header)))
(cdr *command-table*))
(newline)
- (display "Enter `,COMMAND -h' to display documentation of each command.")
+ (display "Type `,COMMAND -h' to show documentation of each command.")
(newline))
(('all)
(for-each display-group *command-table*))
((? lookup-group group)
(display-group (lookup-group group)))
- (else (user-error "Unknown command group: ~A" (car args)))))
+ (else
+ (user-error "Unknown command group: ~A" (car args)))))
-(define guile-apropos apropos)
+(define guile:apropos apropos)
(define (apropos repl regexp)
- "apropos [options] REGEXP
+ "apropos REGEXP
Find bindings/modules/packages."
- (guile-apropos (object->string regexp display)))
+ (guile:apropos (->string regexp)))
(define (describe repl obj)
"describe OBJ
Show description/documentation."
- (display "Not implemented yet\n"))
+ (display (object-documentation (repl-eval repl obj)))
+ (newline))
(define (option repl . args)
- "option [KEY [VALUE]]
+ "option [KEY VALUE]
List/show/set options."
- (display "Not implemented yet\n"))
+ (match args
+ (()
+ (for-each (lambda (key+val)
+ (format #t "~A\t~A\n" (car key+val) (cdr key+val)))
+ repl.options))
+ ((key)
+ (display (repl-option-ref repl key))
+ (newline))
+ ((key val)
+ (repl-option-set! repl key val)
+ (case key
+ ((trace)
+ (if val
+ (apply vm-trace-on repl.env.vm val)
+ (vm-trace-off repl.env.vm)))))))
(define (quit repl)
"quit
"module [MODULE]
Change modules / Show current module."
(match args
- (() (puts (binding repl.module)))))
+ (() (puts (binding repl.env.module)))))
(define (use repl . args)
"use [MODULE ...]
(define (use name)
(let ((mod (resolve-interface name)))
(if mod
- (module-use! repl.module mod)
+ (module-use! repl.env.module mod)
(user-error "No such module: ~A" name))))
(if (null? args)
(for-each puts (map module-name
- (cons repl.module (module-uses repl.module))))
+ (cons repl.env.module
+ (module-uses repl.env.module))))
(for-each (lambda (name)
(cond
((pair? name) (use name))
(define (use name)
(let ((mod (resolve-interface name)))
(if mod
- (module-use! repl.module mod)
+ (module-use! repl.env.module mod)
(user-error "No such module: ~A" name))))
(if (null? args)
(for-each puts (map module-name
- (cons repl.module (module-uses repl.module))))
+ (cons repl.env.module (module-uses repl.env.module))))
(for-each (lambda (name)
(cond
((pair? name) (use name))
args)))
(define (load repl file . opts)
- "load [options] FILE
-Load a file in the current module."
- (apply repl-load-file repl (->string file) opts))
+ "load FILE
+Load a file in the current module.
+
+ -f Load source file (see `compile')"
+ (let* ((file (->string file))
+ (objcode (if (memq :f opts)
+ (apply load-source-file file opts)
+ (apply load-file file opts))))
+ (vm-load repl.env.vm objcode)))
(define (binding repl . opts)
- "binding [-a]
+ "binding
List current bindings."
- (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.module))
-
-(define (lsmod repl . args)
- "lsmod
-."
- (define (use name)
- (set! repl.module (resolve-module name))
- (module-use! repl.module repl.value-history))
- (if (null? args)
- (use '(guile-user))
- (let ((name (car args)))
- (cond
- ((pair? name) (use name))
- ((symbol? name)
- (and-let* ((m (find-one-module (symbol->string name))))
- (puts m) (use m)))
- (else (user-error "Invalid module name: ~A" name))))))
-
-\f
-;;;
-;;; Package commands
-;;;
-
-(define (package repl)
- "package [PACKAGE]
-List available packages/modules."
- (for-each puts (find-module "")))
-
-(define (lspkg repl)
- "lspkg
-List available packages/modules."
- (for-each puts (find-module "")))
-
-(define (autopackage repl)
- "autopackage
-List available packages/modules."
- (for-each puts (find-module "")))
-
-(define (globals repl)
- "globals
-List all global variables."
- (global-fold (lambda (s v d) (format #t "~A\t~S\n" s v)) #f))
+ (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.env.module))
\f
;;;
(define (language repl name)
"language LANGUAGE
Change languages."
- (set! repl.language (lookup-language name))
+ (set! repl.env.language (lookup-language name))
(repl-welcome repl))
\f
;;;
(define (compile repl form . opts)
- "compile [options] FORM
+ "compile FORM
Generate compiled code.
-e Stop after expanding syntax/macro
-O Enable optimization
-D Add debug information"
(let ((x (apply repl-compile repl form opts)))
- (cond ((null? opts)
- (disassemble-bootcode x))
- ((memq :c opts)
- (pprint-glil x))
- (else (puts x)))))
+ (cond ((or (memq :e opts) (memq :t opts)) (puts x))
+ ((memq :c opts) (pprint-glil x))
+ (else (disassemble-objcode x)))))
+(define guile:compile-file compile-file)
(define (compile-file repl file . opts)
- "compile-file [options] FILE
+ "compile-file FILE
Compile a file."
- (apply repl-compile-file repl (->string file) opts))
+ (apply guile:compile-file (->string file) opts))
(define (disassemble repl prog)
"disassemble PROGRAM
(define (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
- (disassemble-bootcode
- (load-file-in (->string file) repl.module repl.language)))
-
-(define (->string x)
- (object->string x display))
+ (disassemble-objcode (load-objcode (->string file))))
\f
;;;
;;; Profile commands
;;;
+(define (time repl form)
+ "time FORM
+Time execution."
+ (let* ((vms-start (vm-stats repl.env.vm))
+ (gc-start (gc-run-time))
+ (tms-start (times))
+ (result (repl-eval repl form))
+ (tms-end (times))
+ (gc-end (gc-run-time))
+ (vms-end (vm-stats repl.env.vm)))
+ (define (get proc start end)
+ (/ (- (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 (profile repl form . opts)
"profile FORM
Profile execution."
- (apply vm-profile repl.vm (repl-compile repl form) opts))
+ (apply vm-profile repl.env.vm (repl-compile repl form) opts))
\f
;;;
;;; Debug commands
;;;
-(define guile-backtrace backtrace)
(define (backtrace repl)
"backtrace
-Show backtrace (if any)."
- (guile-backtrace))
+Display backtrace."
+ (vm-backtrace repl.env.vm))
(define (debugger repl)
"debugger
Start debugger."
- (debug))
+ (vm-debugger repl.env.vm))
(define (trace repl form . opts)
- "trace [-a] FORM
-Trace execution."
- (apply vm-trace repl.vm (repl-compile repl form) opts))
+ "trace FORM
+Trace execution.
+
+ -s Display stack
+ -l Display local variables
+ -e Display external variables
+ -b Bytecode level trace"
+ (apply vm-trace repl.env.vm (repl-compile repl form) opts))
(define (step repl)
"step FORM
;;; System commands
;;;
-(define (time repl form)
- "time FORM
-Time execution."
- (let* ((vms-start (vm-stats repl.vm))
- (gc-start (gc-run-time))
- (tms-start (times))
- (result (repl-eval repl form))
- (tms-end (times))
- (gc-end (gc-run-time))
- (vms-end (vm-stats repl.vm)))
- (define (get proc start end)
- (/ (- (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 id gc-start gc-end))
- result))
-
-;;;
-;;; Statistics
-;;;
-
-(define guile-gc gc)
+(define guile:gc gc)
(define (gc repl)
"gc
Garbage collection."
- (guile-gc))
-
-(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" (/ 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))))
- (display-stat title #f
- (mips (- this-time last-time) (- this-clock last-clock))
- (mips this-time this-clock) "mips"))
+ (guile:gc))
(define (statistics repl)
"statistics
Display statistics."
(let ((this-tms (times))
- (this-vms (vm-stats repl.vm))
+ (this-vms (vm-stats repl.env.vm))
(this-gcs (gc-stats))
(last-tms repl.tm-stats)
(last-vms repl.vm-stats)
(set! repl.tm-stats this-tms)
(set! repl.vm-stats this-vms)
(set! repl.gc-stats 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" (/ 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))))
+ (display-stat title #f
+ (mips (- this-time last-time) (- this-clock last-clock))
+ (mips this-time this-clock) "mips"))
HCoop / bpt / guile.git / blobdiff