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

@@ -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)))
 
 
 ;;;

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
+<http://www.gnu.org/licenses/lgpl.html>.")
+
+(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 <http://www.gnu.org/licenses/lgpl.html>, 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)