From dca9a4d68556479a25d0e26fb8ac45c0f872efcd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 23 Mar 2010 00:18:48 +0100 Subject: [PATCH] make guile's welcome more gnu-conventional; also warranty and copying info * 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*. --- module/system/repl/command.scm | 69 +++++++++++++++++++++++++------- module/system/repl/common.scm | 72 +++++++++++++++++++++++++++++++--- 2 files changed, 121 insertions(+), 20 deletions(-) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 67feeb162..e5e77cb5a 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -44,7 +44,7 @@ ;;; (define *command-table* - '((help (help h) (apropos a) (describe d) (option o) (quit q)) + '((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) @@ -53,17 +53,12 @@ (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)) -;; Hack, until core can be extended. -(define procedure-documentation - (let ((old-definition procedure-documentation)) - (lambda (p) - (if (program? p) - (program-documentation p) - (old-definition p))))) - (define *command-module* (current-module)) (define (command-name c) (car c)) (define (command-abbrev c) (if (null? (cdr c)) #f (cadr c))) @@ -84,19 +79,19 @@ (define (lookup-group name) (assq name *command-table*)) -(define (lookup-command key) - (let loop ((groups *command-table*) (commands '())) +(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 . opts) +(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) - (command-abbrev c) + (and abbrev? (command-abbrev c)) (command-summary c))) (group-commands group)) (newline)) @@ -203,6 +198,47 @@ are displayed." (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 @@ -286,8 +322,11 @@ List current bindings." (define-meta-command (language repl name) "language LANGUAGE Change languages." - (set! (repl-language repl) (lookup-language name)) - (repl-welcome repl)) + (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))) ;;; diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index c760c891e..a106145a2 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -28,7 +28,70 @@ repl-tm-stats repl-gc-stats repl-welcome repl-prompt repl-read repl-compile repl-eval repl-parse repl-print repl-option-ref repl-option-set! - puts ->string user-error)) + 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 +.") + +(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 , for more details.") ;;; @@ -49,10 +112,9 @@ #:gc-stats (gc-stats))) (define (repl-welcome repl) - (let ((language (repl-language repl))) - (format #t "~A interpreter ~A on Guile ~A\n" - (language-title language) (language-version language) (version))) - (display "Copyright (C) 2001-2008 Free Software Foundation, Inc.\n\n") + (display *version*) + (newline) + (newline) (display "Enter `,help' for help.\n")) (define (repl-prompt repl)