Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	libguile/debug.h
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
	module/language/tree-il/peval.scm
	module/language/tree-il/primitives.scm

module/language/scheme/spec.scm

@@ -1,6 +1,6 @@
 ;;; Guile Scheme specification
 
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -53,4 +53,11 @@
                     ;; compile-time changes to `current-reader' are
                     ;; limited to the current compilation unit.
                     (module-define! m 'current-reader (make-fluid))
+
+                    ;; Default to `simple-format', as is the case until
+                    ;; (ice-9 format) is loaded.  This allows
+                    ;; compile-time warnings to be emitted when using
+                    ;; unsupported options.
+                    (module-set! m 'format simple-format)
+
                     m)))

module/language/tree-il/analyze.scm

@@ -22,6 +22,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (system base syntax)
@@ -1392,7 +1393,7 @@ accurate information is missing from a given `tree-il' element."
          ((,port ,fmt . ,rest)
           (if (and (const? port)
                    (not (boolean? (const-exp port))))
-              (warn 'format loc 'wrong-port (const-exp port)))
+              (warning 'format loc 'wrong-port (const-exp port)))
           ;; Warn on non-literal format strings, unless they refer to a
           ;; lexical variable named "fmt".
           (if (record-case fmt
@@ -1403,6 +1404,36 @@ accurate information is missing from a given `tree-il' element."
          (else
           (warning 'format loc 'wrong-num-args (length args)))))
 
+     (define (check-simple-format-args args loc)
+       ;; Check the arguments to the `simple-format' procedure, which is
+       ;; less capable than that of (ice-9 format).
+
+       (define allowed-chars
+         '(#\A #\S #\a #\s #\~ #\%))
+
+       (define (format-chars fmt)
+         (let loop ((chars  (string->list fmt))
+                    (result '()))
+           (match chars
+             (()
+              (reverse result))
+             ((#\~ opt rest ...)
+              (loop rest (cons opt result)))
+             ((_ rest ...)
+              (loop rest result)))))
+
+       (match args
+         ((port ($ <const> _ (? string? fmt)) _ ...)
+          (let ((opts (format-chars fmt)))
+            (or (every (cut memq <> allowed-chars) opts)
+                (begin
+                  (warning 'format loc 'simple-format fmt
+                           (find (negate (cut memq <> allowed-chars)) opts))
+                  #f))))
+         ((port (($ <const> _ '_) fmt) args ...)
+          (check-simple-format-args `(,port ,fmt ,args) loc))
+         (_ #t)))
+
      (define (resolve-toplevel name)
        (and (module? env)
             (false-if-exception (module-ref env name))))
@@ -1410,9 +1441,19 @@ accurate information is missing from a given `tree-il' element."
      (match x
        (($ <call> src ($ <toplevel-ref> _ name) args)
         (let ((proc (resolve-toplevel name)))
-          (and (or (eq? proc format)
-                   (eq? proc (@ (ice-9 format) format)))
-               (check-format-args args (or src (find pair? locs))))))
+          (if (or (and (eq? proc (@ (guile) simple-format))
+                       (check-simple-format-args args
+                                                 (or src (find pair? locs))))
+                  (eq? proc (@ (ice-9 format) format)))
+              (check-format-args args (or src (find pair? locs))))))
+       (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+        (check-format-args args (or src (find pair? locs))))
+       (($ <call> src ($ <module-ref> _ '(guile)
+                         (or 'format 'simple-format))
+           args)
+        (and (check-simple-format-args args
+                                       (or src (find pair? locs)))
+             (check-format-args args (or src (find pair? locs)))))
        (_ #t))
      #t)
 

module/language/tree-il/peval.scm

@@ -411,7 +411,7 @@ top-level bindings from ENV and return the resulting expression."
   (define (fresh-gensyms vars)
     (map (lambda (var)
            (let ((new (gensym (string-append (symbol->string (var-name var))
-                                             " "))))
+                                             "-"))))
              (set! store (vhash-consq new var store))
              new))
          vars))

module/language/tree-il/primitives.scm

@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -487,8 +487,8 @@
             '@dynamic-wind
             (case-lambda
               ((src pre expr post)
-               (let ((PRE (gensym " pre"))
-                     (POST (gensym " post")))
+               (let ((PRE (gensym "pre-"))
+                     (POST (gensym "post-")))
                  (make-let
                   src
                   '(pre post)