diff options
Diffstat (limited to 'module/system/repl')
-rw-r--r-- | module/system/repl/.cvsignore | 1 | ||||
-rw-r--r-- | module/system/repl/command.scm | 205 | ||||
-rw-r--r-- | module/system/repl/common.scm | 86 | ||||
-rw-r--r-- | module/system/repl/describe.scm | 19 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 6 |
5 files changed, 136 insertions, 181 deletions
diff --git a/module/system/repl/.cvsignore b/module/system/repl/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/system/repl/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index c665499d1..1d374722a 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -21,37 +21,31 @@ (define-module (system repl command) :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) + :autoload (system il glil) (pprint-glil) + :autoload (system vm disasm) (disassemble-program disassemble-objcode) :autoload (system vm trace) (vm-trace) - :autoload (system vm disasm) (disassemble-program disassemble-dumpcode) :autoload (system vm profile) (vm-profile) :use-module (ice-9 format) :use-module (ice-9 session) - :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)) ;;; -;;; 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)))) + (debug (backtrace bt) (debugger db) (trace r) (step st)) + (system (gc) (statistics st)))) (define (group-name g) (car g)) (define (group-commands g) (cdr g)) @@ -102,7 +96,7 @@ (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)) @@ -125,10 +119,10 @@ (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)) @@ -141,27 +135,29 @@ all command groups are displayed, as you have already seen :)" (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")) @@ -179,7 +175,7 @@ Quit this session." "module [MODULE] Change modules / Show current module." (match args - (() (puts (binding repl.module))))) + (() (puts (binding repl.env.module))))) (define (use repl . args) "use [MODULE ...] @@ -187,11 +183,12 @@ Use modules." (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)) @@ -206,11 +203,11 @@ Import modules / List those imported." (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)) @@ -221,55 +218,23 @@ Import modules / List those imported." 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') + -r Trace loading (see `trace')" + (let* ((file (->string file)) + (objcode (if (memq :f opts) + (apply load-source-file file opts) + (apply load-file file opts)))) + (if (memq :r opts) + (apply vm-trace repl.env.vm objcode 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)))))) - - -;;; -;;; 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)) ;;; @@ -279,7 +244,7 @@ List all global variables." (define (language repl name) "language LANGUAGE Change languages." - (set! repl.language (lookup-language name)) + (set! repl.env.language (lookup-language name)) (repl-welcome repl)) @@ -288,7 +253,7 @@ Change languages." ;;; (define (compile repl form . opts) - "compile [options] FORM + "compile FORM Generate compiled code. -e Stop after expanding syntax/macro @@ -300,10 +265,10 @@ Generate compiled code. (let ((x (apply repl-compile repl form opts))) (cond ((or (memq :e opts) (memq :t opts)) (puts x)) ((memq :c opts) (pprint-glil x)) - (else (disassemble-dumpcode x))))) + (else (disassemble-objcode x))))) (define (compile-file repl file . opts) - "compile-file [options] FILE + "compile-file FILE Compile a file." (apply repl-compile-file repl (->string file) opts)) @@ -315,31 +280,51 @@ Disassemble a program." (define (disassemble-file repl file) "disassemble-file FILE Disassemble a file." - (disassemble-dumpcode (load-dumpcode (->string file)))) - -(define (->string x) - (object->string x display)) + (disassemble-objcode (load-objcode (->string file)))) ;;; ;;; 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)) ;;; ;;; Debug commands ;;; -(define guile-backtrace backtrace) +(define guile:backtrace backtrace) (define (backtrace repl) "backtrace Show backtrace (if any)." - (guile-backtrace)) + (guile:backtrace)) (define (debugger repl) "debugger @@ -347,9 +332,14 @@ Start debugger." (debug)) (define (trace repl form . opts) - "trace [-b] 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 @@ -361,44 +351,17 @@ Step execution." ;;; 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)) - -(define guile-gc gc) +(define guile:gc gc) (define (gc repl) "gc Garbage collection." - (guile-gc)) - -;;; -;;; Statistics -;;; + (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) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 651bd5205..4bd8986a9 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -22,70 +22,66 @@ (define-module (system repl common) :use-module (oop goops) :use-syntax (system base syntax) + :use-module (system base compile) :use-module (system base language) :use-module (system vm core) - :use-module (system vm trace) - :export (make-repl repl-welcome repl-prompt repl-read repl-compile - repl-eval repl-print repl-compile-file repl-load-file)) + :use-module (system vm trace)) ;;; -;;; Repl +;;; Repl type ;;; -(define-vm-class <repl> () - vm language module value-count value-history tm-stats vm-stats gc-stats) +(define-vm-class <repl> () env tm-stats vm-stats gc-stats) -(define (make-repl lang) - (let ((vm (the-vm))) +(define-public (make-repl lang) + (let ((cenv (make-cenv :vm (the-vm) + :language (lookup-language lang) + :module (current-module)))) (make <repl> - :vm vm - :language (lookup-language lang) - :module (current-module) ;; (global-ref 'user) - :value-count 0 -; :value-history (make-vmodule) + :env cenv :tm-stats (times) - :vm-stats (vm-stats vm) + :vm-stats (vm-stats cenv.vm) :gc-stats (gc-stats)))) -(define (repl-welcome repl) +(define-public (repl-welcome repl) (format #t "~A interpreter ~A on Guile ~A\n" - repl.language.title repl.language.version (version)) + repl.env.language.title repl.env.language.version (version)) (display "Copyright (C) 2001 Free Software Foundation, Inc.\n\n") (display "Enter `,help' for help.\n")) -(define (repl-prompt repl) - (format #t "~A@~A> " repl.language.name 'guile) - ;; (env-identifier repl.module)) - (force-output)) +(define-public (repl-prompt repl) + (let ((module-name (car (last-pair (module-name repl.env.module))))) + (format #t "~A@~A> " repl.env.language.name module-name) + (force-output))) -(define (repl-read repl . args) - (apply read-in repl.language args)) +(define-public (repl-read repl) + (repl.env.language.reader)) -(define (repl-compile repl form . opts) - (apply compile-in form repl.module repl.language opts)) +(define-public (repl-compile repl form . opts) + (apply compile-in form repl.env.module repl.env.language opts)) -(define (repl-eval repl form) - (let ((eval repl.language.evaluator)) +(define-public (repl-eval repl form) + (let ((eval repl.env.language.evaluator)) (if eval - (eval form repl.module) - (vm-load repl.vm (repl-compile repl form))))) + (eval form repl.env.module) + (vm-load repl.env.vm (repl-compile repl form))))) -(define (repl-print repl val) +(define-public (repl-print repl val) (if (not (eq? val *unspecified*)) - (let* ((num (1+ repl.value-count)) - (sym (string->symbol (format #f "$~A" num)))) -; (vmodule-define repl.value-history sym val) - (format #t "~A = " sym) - (print-in val repl.language) - (newline) - (set! repl.value-count num)))) - -(define (repl-compile-file repl file . opts) - (apply compile-file-in file repl.language opts)) - -(define (repl-load-file repl file . opts) - (let ((bytes (apply repl-compile-file repl file opts))) - (if (or (memq :b opts) (memq :r opts)) - (apply vm-trace repl.vm bytes opts) - (vm-load repl.vm bytes)))) + (begin + (repl.env.language.printer val) + (newline)))) + + +;;; +;;; Utilities +;;; + +(define-public (puts x) (display x) (newline)) + +(define-public (->string x) + (object->string x display)) + +(define-public (user-error msg . args) + (throw 'user-error #f msg args #f)) diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm index 966ea7d46..15f0b0b04 100644 --- a/module/system/repl/describe.scm +++ b/module/system/repl/describe.scm @@ -22,16 +22,15 @@ (define-module (system repl describe) :use-module (oop goops) :use-module (ice-9 regex) - :use-module (ice-9 format)) + :use-module (ice-9 format) + :use-module (ice-9 and-let-star) + :export (describe)) -(define *describe-format* #t) - -(define-public (describe symbol) - (assert symbol? symbol) +(define-method (describe (symbol <symbol>)) (format #t "`~s' is " symbol) (if (not (defined? symbol)) (display "not defined in the current module.\n") - (describe-object (eval symbol)))) + (describe-object (module-ref (current-module) symbol)))) ;;; @@ -302,13 +301,13 @@ ;;; Instances ;;; -(define-method display-type ((obj <object>)) +(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>)) +(define-method (display-value (obj <object>)) (display-slot-list #f obj (class-slots (class-of obj)))) @@ -316,13 +315,13 @@ ;;; Generic functions ;;; -(define-method display-type ((obj <generic>)) +(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>)) +(define-method (display-value (obj <generic>)) (display-list #f (generic-function-methods obj))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 5c01c8b3a..73473af8c 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -23,14 +23,11 @@ :use-syntax (system base syntax) :use-module (system repl common) :use-module (system repl command) - :use-module (system vm frame) :use-module (ice-9 rdelim) :export (start-repl)) (define (start-repl lang) (let ((repl (make-repl lang))) -;; (set-current-vmodule! repl.module) -;; (set-current-evaluator! repl.vm) (repl-welcome repl) (let prompt-loop () (repl-prompt repl) @@ -38,8 +35,7 @@ (lambda () (if (eq? (next-char #t) #\,) ;; meta command - (begin (read-char) - (meta-command repl (read-line))) + (begin (read-char) (meta-command repl (read-line))) ;; evaluation (let rep-loop () (repl-print repl (repl-eval repl (repl-read repl))) |