guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. release_1-9-9-10-gdca


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-9-10-gdca9a4d
Date: Mon, 22 Mar 2010 23:17:08 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=dca9a4d68556479a25d0e26fb8ac45c0f872efcd

The branch, master has been updated
       via  dca9a4d68556479a25d0e26fb8ac45c0f872efcd (commit)
      from  1ea8aa7d8e980ce0dc17938058d4665b0c1193b9 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit dca9a4d68556479a25d0e26fb8ac45c0f872efcd
Author: Andy Wingo <address@hidden>
Date:   Tue Mar 23 00:18:48 2010 +0100

    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*.

-----------------------------------------------------------------------

Summary of changes:
 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 67feeb1..e5e77cb 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 c760c89..a106145 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
+<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)


hooks/post-receive
-- 
GNU Guile




reply via email to

[Prev in Thread] Current Thread [Next in Thread]