From ea9c5daba067029aab6dd46626bba9d1397cccd1 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Thu, 5 Apr 2001 02:04:26 +0000 Subject: [PATCH] *** empty log message *** --- module/language/elisp/spec.scm | 44 ++- module/language/elisp/translate.scm | 45 --- module/language/ghil/spec.scm | 8 +- module/language/gscheme/spec.scm | 8 +- module/language/r5rs/core.il | 10 +- module/language/r5rs/expand.scm | 38 ++- module/language/r5rs/null.il | 8 +- module/language/r5rs/psyntax.boot | 38 ++- module/language/r5rs/spec.scm | 41 ++- module/language/r5rs/translate.scm | 60 ---- module/system/repl/command.gs | 488 ++++++++++++++++++++++++++++ module/system/repl/command.scm | 4 +- module/system/repl/common.scm | 4 +- module/system/repl/describe.scm | 4 +- 14 files changed, 624 insertions(+), 176 deletions(-) delete mode 100644 module/language/elisp/translate.scm delete mode 100644 module/language/r5rs/translate.scm create mode 100644 module/system/repl/command.gs diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm index 4f185522e..c43328c22 100644 --- a/module/language/elisp/spec.scm +++ b/module/language/elisp/spec.scm @@ -1,29 +1,59 @@ -;;; Guile Emac Lisp language specification +;;; Guile Emac Lisp ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This file is part of Guile VM. - -;; Guile VM is free software; you can redistribute it and/or modify +;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; -;; Guile VM is distributed in the hope that it will be useful, +;; This program 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 General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to +;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Code: + (define-module (lang elisp spec) :use-module (system lang language) - :use-module (lang elisp translate) :export (elisp)) + +;;; +;;; Translator +;;; + +(define (translate x) + (if (pair? x) + (translate-pair x) + x)) + +(define (translate-pair x) + (let ((name (car x)) (args (cdr x))) + (case name + ((quote) `(@quote ,@args)) + ((defvar) `(@define ,@(map translate args))) + ((setq) `(@set! ,@(map translate args))) + ((if) `(@if ,(translate (car args)) + (@begin ,@(map translate (cdr args))))) + ((and) `(@and ,@(map translate args))) + ((or) `(@or ,@(map translate args))) + ((progn) `(@begin ,@(map translate args))) + ((defun) `(@define ,(car args) + (@lambda ,(cadr args) ,@(map translate (cddr args))))) + ((lambda) `(@lambda ,(car args) ,@(map translate (cdr args)))) + (else x)))) + + +;;; +;;; Language definition +;;; + (define-language elisp #:title "Emacs Lisp" #:version "0.0" diff --git a/module/language/elisp/translate.scm b/module/language/elisp/translate.scm deleted file mode 100644 index 32b6e6dd6..000000000 --- a/module/language/elisp/translate.scm +++ /dev/null @@ -1,45 +0,0 @@ -;;; Emacs Lisp to GHIL translator - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This file is part of Guile VM. - -;; Guile VM is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; Guile VM 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 General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(define-module (lang elisp translate) - :export (translate)) - -(define (translate x) (trans x)) - -(define (trans x) - (if (pair? x) - (trans-pair x) - x)) - -(define (trans-pair x) - (let ((name (car x)) (args (cdr x))) - (case name - ((quote) `(@quote ,@args)) - ((defvar) `(@define ,@(map trans args))) - ((setq) `(@set! ,@(map trans args))) - ((if) `(@if ,(trans (car args)) (@begin ,@(map trans (cdr args))))) - ((and) `(@and ,@(map trans args))) - ((or) `(@or ,@(map trans args))) - ((progn) `(@begin ,@(map trans args))) - ((defun) `(@define ,(car args) - (@lambda ,(cadr args) ,@(map trans (cddr args))))) - ((lambda) `(@lambda ,(car args) ,@(map trans (cdr args)))) - (else x)))) diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm index d37da3298..b9679748a 100644 --- a/module/language/ghil/spec.scm +++ b/module/language/ghil/spec.scm @@ -2,21 +2,23 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; Guile VM is free software; you can redistribute it and/or modify +;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; -;; Guile VM is distributed in the hope that it will be useful, +;; This program 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 General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to +;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Code: + (define-module (language ghil spec) :use-module (system base language) :export (ghil)) diff --git a/module/language/gscheme/spec.scm b/module/language/gscheme/spec.scm index c2a9ed7b6..5cbbc6409 100644 --- a/module/language/gscheme/spec.scm +++ b/module/language/gscheme/spec.scm @@ -2,21 +2,23 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; Guile VM is free software; you can redistribute it and/or modify +;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; -;; Guile VM is distributed in the hope that it will be useful, +;; This program 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 General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to +;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Code: + (define-module (language gscheme spec) :use-module (system base language) :use-module (ice-9 match) diff --git a/module/language/r5rs/core.il b/module/language/r5rs/core.il index 1e282ea5a..ad40fcc1a 100644 --- a/module/language/r5rs/core.il +++ b/module/language/r5rs/core.il @@ -2,23 +2,23 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This file is part of Guile VM. - -;; Guile VM is free software; you can redistribute it and/or modify +;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; -;; Guile VM is distributed in the hope that it will be useful, +;; This program 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 General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to +;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Code: + ;; Non standard procedures (@define void (@lambda () (@void))) diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm index 610dc0974..5a1a04bb2 100644 --- a/module/language/r5rs/expand.scm +++ b/module/language/r5rs/expand.scm @@ -1,21 +1,23 @@ -;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program 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 General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; - +;;; R5RS syntax expander + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: (define-module (language r5rs expand) :export (expand void diff --git a/module/language/r5rs/null.il b/module/language/r5rs/null.il index 3d63b9b00..efdc5f398 100644 --- a/module/language/r5rs/null.il +++ b/module/language/r5rs/null.il @@ -2,17 +2,19 @@ ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; Guile VM is free software; you can redistribute it and/or modify +;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; -;; Guile VM is distributed in the hope that it will be useful, +;; This program 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 General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to +;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. + +;;; Code: diff --git a/module/language/r5rs/psyntax.boot b/module/language/r5rs/psyntax.boot index e47c0ec80..0e57bcadc 100644 --- a/module/language/r5rs/psyntax.boot +++ b/module/language/r5rs/psyntax.boot @@ -1,21 +1,23 @@ -;;;; Copyright (C) 1997, 2000 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program 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 General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; - +;;; psyntax.ss -> psyntax.scm + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: (define sc-expand #f) (define $sc-put-cte #f) diff --git a/module/language/r5rs/spec.scm b/module/language/r5rs/spec.scm index 98b6e9dcd..560f72d09 100644 --- a/module/language/r5rs/spec.scm +++ b/module/language/r5rs/spec.scm @@ -1,30 +1,59 @@ -;;; Guile R5RS specification +;;; Guile R5RS ;; Copyright (C) 2001 Free Software Foundation, Inc. -;; This file is part of Guile VM. - -;; Guile VM is free software; you can redistribute it and/or modify +;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; -;; Guile VM is distributed in the hope that it will be useful, +;; This program 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 General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to +;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Code: + (define-module (language r5rs spec) :use-module (system base language) :use-module (language r5rs expand) :use-module (language r5rs translate) :export (r5rs)) + +;;; +;;; Translator +;;; + +(define (translate x) (if (pair? x) (translate-pair x) x)) + +(define (translate-pair x) + (let ((name (car x)) (args (cdr x))) + (case name + ((quote) (cons '@quote args)) + ((define set! if and or begin) + (cons (symbol-append '@ name) (map translate args))) + ((let let* letrec) + (cons* (symbol-append '@ name) + (map (lambda (b) + (cons (car b) (map translate (cdr b)))) + (car args)) + (map translate (cdr args)))) + ((lambda) + (cons* '@lambda (car args) (map translate (cdr args)))) + (else + (cons (translate name) (map translate args)))))) + + +;;; +;;; Language definition +;;; + (define-language r5rs :title "Standard Scheme (R5RS + syntax-case)" :version "0.3" diff --git a/module/language/r5rs/translate.scm b/module/language/r5rs/translate.scm deleted file mode 100644 index 74d008c02..000000000 --- a/module/language/r5rs/translate.scm +++ /dev/null @@ -1,60 +0,0 @@ -;;; translate.scm --- Scheme to Guile IL translator - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This file is part of Guile VM. - -;; Guile VM is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; Guile VM 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 General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Guile VM; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -(define-module (language r5rs translate) - :export (translate)) - -(define (translate x) (trans x)) - -(define (trans x) (if (pair? x) (trans-pair x) x)) - -(define (trans-pair x) - (let ((name (car x)) (args (cdr x))) - (let ((il (case name - ((quote) (cons '@quote args)) - ((define set! if and or begin) - (cons (symbol-append '@ name) (map trans args))) - ((let let* letrec) - (cons* (symbol-append '@ name) - (map (lambda (b) - (cons (car b) (map trans (cdr b)))) - (car args)) - (map trans (cdr args)))) - ((lambda) - (cons* '@lambda (trans-formals (car args)) - (map trans (cdr args)))) - (else - (cons (trans name) (map trans args))))) - (props (source-properties x))) - (if (not (null? props)) - (set-source-properties! il props)) - il))) - -(define (trans-formals formals) - (cond ((symbol? formals) `(:rest ,formals)) - ((or (null? formals) (null? (cdr (last-pair formals)))) formals) - (else - (let* ((list (list-copy formals)) - (last (last-pair list))) - (set-cdr! last `(:rest ,(cdr last))) - list)))) - -;;; translate.scm ends here diff --git a/module/system/repl/command.gs b/module/system/repl/command.gs new file mode 100644 index 000000000..9de2cd79e --- /dev/null +++ b/module/system/repl/command.gs @@ -0,0 +1,488 @@ +;;; Repl commands + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define (puts x) (display x) (newline)) + +(define (user-error msg . args) + (throw 'user-error #f msg args #f)) + + +;;; +;;; Meta command +;;; + +(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)) + (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)))) + +(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) + (let loop ((groups *command-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 . opts) + (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group)) + (for-each (lambda (c) + (display-summary (command-usage c) + (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 (meta-command repl line) + (let ((input (call-with-input-string (string-append "(" line ")") read))) + (if (not (null? input)) + (do ((key (car input)) + (args (cdr input) (cdr args)) + (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts))) + ((or (null? args) + (not (symbol? (car args))) + (not (eq? (string-ref (symbol->string (car args)) 0) #\-))) + (let ((c (lookup-command key))) + (if c + (cond ((memq :h opts) (display-command c)) + (else (apply (command-procedure c) + repl (append! args opts)))) + (user-error "Unknown meta command: ~A" key)))))))) + + +;;; +;;; Help commands +;;; + +(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 :)" + (match 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 "Enter `,COMMAND -h' to display 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))))) + +(define guile-apropos apropos) +(define (apropos repl regexp) + "apropos [options] REGEXP +Find bindings/modules/packages." + (guile-apropos (object->string regexp display))) + +(define (describe repl obj) + "describe OBJ +Show description/documentation." + (display "Not implemented yet\n")) + +(define (option repl . args) + "option [KEY [VALUE]] +List/show/set options." + (display "Not implemented yet\n")) + +(define (quit repl) + "quit +Quit this session." + (throw 'quit)) + + +;;; +;;; Module commands +;;; + +(define (module repl . args) + "module [MODULE] +Change modules / Show current module." + (match args + (() (puts (binding repl.module))))) + +(define (use repl . args) + "use [MODULE ...] +Use modules." + (define (use name) + (let ((mod (resolve-interface name))) + (if mod + (module-use! repl.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)))) + (for-each (lambda (name) + (cond + ((pair? name) (use name)) + ((symbol? name) + (cond ((find-one-module (symbol->string name)) => use))) + (else (user-error "Invalid module name: ~A" name)))) + args))) + +(define (import repl . args) + "import [MODULE ...] +Import modules / List those imported." + (define (use name) + (let ((mod (resolve-interface name))) + (if mod + (module-use! repl.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)))) + (for-each (lambda (name) + (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)))) + args))) + +(define (load repl file . opts) + "load [options] FILE +Load a file in the current module." + (apply repl-load-file repl (->string file) opts)) + +(define (binding repl . opts) + "binding [-a] +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)) + + +;;; +;;; Language commands +;;; + +(define (language repl name) + "language LANGUAGE +Change languages." + (set! repl.language (lookup-language name)) + (repl-welcome repl)) + + +;;; +;;; Compile commands +;;; + +(define (compile repl form . opts) + "compile [options] FORM +Generate compiled code. + + -e Stop after expanding syntax/macro + -t Stop after translating into GHIL + -c Stop after generating GLIL + -l Stop before linking + -o Compile into bytecode + + -O Enable optimization + -D Add debug information" + (let ((x (apply repl-compile repl form opts))) + (cond ((null? opts) + (disassemble-program x)) + ((memq :l opts) + (disassemble-bytecode x)) + ((memq :c opts) + (pprint-glil x)) + (else + (puts x))))) + +(define (compile-file repl file . opts) + "compile-file [options] FILE +Compile a file." + (apply repl-compile-file repl (->string file) opts)) + +(define (disassemble repl prog) + "disassemble PROGRAM +Disassemble a program." + (disassemble-program (repl.vm (repl-compile repl prog)))) + +(define (disassemble-file repl file) + "disassemble-file FILE +Disassemble a file." + (disassemble-bytecode (load-file-in (->string file) + repl.module + repl.language))) + +(define (->string x) + (object->string x display)) + + +;;; +;;; Profile commands +;;; + +(define (profile repl form . opts) + "profile FORM +Profile execution." + (apply vm-profile repl.vm (repl-compile repl form) opts)) + + +;;; +;;; Debug commands +;;; + +(define guile-backtrace backtrace) +(define (backtrace repl) + "backtrace +Show backtrace (if any)." + (guile-backtrace)) + +(define (debugger repl) + "debugger +Start debugger." + (debug)) + +(define (trace repl form . opts) + "trace [-a] FORM +Trace execution." + (apply vm-trace repl.vm (repl-compile repl form) opts)) + +(define (step repl) + "step FORM +Step execution." + (display "Not implemented yet\n")) + + +;;; +;;; 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 (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")) + +(define (statistics repl) + "statistics +Display statistics." + (let ((this-tms (times)) + (this-vms (vm-stats repl.vm)) + (this-gcs (gc-stats)) + (last-tms repl.tm-stats) + (last-vms repl.vm-stats) + (last-gcs repl.gc-stats)) + ;; 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-sweep (assq-ref this-gcs 'gc-sweep-time-taken)) + (last-sweep (assq-ref last-gcs 'gc-sweep-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 "sweep" this-sweep last-sweep) + (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)) + ;; VM statistics + (let ((this-time (vms:time this-vms)) + (last-time (vms:time last-vms)) + (this-clock (vms:clock this-vms)) + (last-clock (vms:clock last-vms))) + (display-stat-title "VM statistics:" "diff" "total") + (display-time-stat "time spent" this-time last-time) + (display-diff-stat "bogoclock" #f this-clock last-clock "clock") + (display-mips-stat "bogomips" this-time this-clock last-time last-clock) + (newline)) + ;; Save statistics + ;; Save statistics + (set! repl.tm-stats this-tms) + (set! repl.vm-stats this-vms) + (set! repl.gc-stats this-gcs))) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 25e723163..9cf21df01 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -1,4 +1,4 @@ -;;; REPL commands +;;; Repl commands ;; Copyright (C) 2001 Free Software Foundation, Inc. @@ -35,4 +35,4 @@ :use-module (ice-9 debugger) :export (meta-command)) -(load "command.gsm") +(load "command.gs") diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index c1c93e286..af4befed7 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -1,4 +1,4 @@ -;;; common.scm --- Repl common routines +;;; Repl common routines ;; Copyright (C) 2001 Free Software Foundation, Inc. @@ -89,5 +89,3 @@ (define (repl-load-file repl file . opts) (let ((bytes (apply load-file-in file repl.module repl.language opts))) (repl.vm (vm-load repl.vm bytes)))) - -;;; common.scm ends here diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm index 17e46621f..966ea7d46 100644 --- a/module/system/repl/describe.scm +++ b/module/system/repl/describe.scm @@ -1,4 +1,4 @@ -;;; describe.scm --- describe objects +;;; Describe objects ;; Copyright (C) 2001 Free Software Foundation, Inc. @@ -360,5 +360,3 @@ (define-method (display-documentation (obj )) (let ((doc (procedure-documentation (method-procedure obj)))) (if doc (format-documentation doc) (next-method)))) - -;;; describe.scm ends here