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

Conflicts:
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
	module/language/bytecode/spec.scm
	module/language/tree-il/spec.scm

.gitignore

@@ -150,3 +150,5 @@ INSTALL
 /lib/dirent.h
 /lib/langinfo.h
 /lib/wctype.h
+/build-aux/ar-lib
+/build-aux/test-driver

configure.ac

@@ -5,7 +5,7 @@ dnl
 define(GUILE_CONFIGURE_COPYRIGHT,[[
 
 Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-  2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+  2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 
 This file is part of GUILE
 
@@ -35,8 +35,11 @@ AC_CONFIG_AUX_DIR([build-aux])
 AC_CONFIG_MACRO_DIR([m4])
 AC_CONFIG_SRCDIR(GUILE-VERSION)
 
-dnl `AM_PROG_AR' was introduced in Automake 1.11.2.
+dnl Use `serial-tests' so the output `check-guile' is not hidden
-AM_INIT_AUTOMAKE([1.11.2 gnu no-define -Wall -Wno-override color-tests dist-xz])
+dnl (`parallel-tests' is the default in Automake 1.13.)
+dnl `serial-tests' was introduced in Automake 1.12.
+AM_INIT_AUTOMAKE([1.12 gnu no-define -Wall -Wno-override \
+  serial-tests color-tests dist-xz])
 m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)])
 
 AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)

doc/ref/compiler.texi

@@ -55,7 +55,8 @@ They are registered with the @code{define-language} form.
 @deffn {Scheme Syntax} define-language @
 name title reader printer @
 [parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] @
-[joiner=#f] [make-default-environment=make-fresh-user-module]
+[joiner=#f] [for-humans?=#t] @
+[make-default-environment=make-fresh-user-module]
 Define a language.
 
 This syntax defines a @code{#<language>} object, bound to @var{name}

doc/ref/sxml-match.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2010  Free Software Foundation, Inc.
+@c Copyright (C) 2010, 2013  Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 @c
 @c Based on the documentation at
@@ -16,10 +16,10 @@
 @cindex pattern matching (SXML)
 @cindex SXML pattern matching
 
-The @code{(sxml match)} module provides syntactic forms for pattern matching of
+The @code{(sxml match)} module provides syntactic forms for pattern
-SXML trees, in a ``by example'' style reminiscent of the pattern matching of the
+matching of SXML trees, in a ``by example'' style reminiscent of the
-@code{syntax-rules} and @code{syntax-case} macro systems.  @xref{sxml simple,
+pattern matching of the @code{syntax-rules} and @code{syntax-case} macro
-the @code{(sxml simple)} module}, for more information on SXML.
+systems.  @xref{SXML}, for more information on SXML.
 
 The following example@footnote{This example is taken from a paper by
 Krishnamurthi et al.  Their paper was the first to show the usefulness of the

doc/ref/texinfo.texi

@@ -152,8 +152,8 @@ interested in @code{replace-titles} and @code{filter-empty-elements}.
 @xref{texinfo docbook replace-titles,,replace-titles}, and @ref{texinfo
 docbook filter-empty-elements,,filter-empty-elements}.
 
-Returns a nodeset, as described in @ref{sxml xpath}. That is to say,
+Returns a nodeset; that is to say, an untagged list of stexi elements.
-this function returns an untagged list of stexi elements.
+@xref{SXPath}, for the definition of a nodeset.
 
 @end defun
 
@@ -184,10 +184,12 @@ For example:
 This module implements transformation from @code{stexi} to HTML. Note
 that the output of @code{stexi->shtml} is actually SXML with the HTML
 vocabulary. This means that the output can be further processed, and
-that it must eventually be serialized by @ref{sxml simple
+that it must eventually be serialized by @code{sxml->xml}.
-sxml->xml,sxml->xml}. References (i.e., the @code{@@ref} family of
+@xref{Reading and Writing XML}.
-commands) are resolved by a @dfn{ref-resolver}. @xref{texinfo html
+
-add-ref-resolver!,add-ref-resolver!}, for more information.
+References (i.e., the @code{@@ref} family of commands) are resolved by a
+@dfn{ref-resolver}.  @xref{texinfo html
+add-ref-resolver!,add-ref-resolver!}.
 
 @subsubsection Usage
 @anchor{texinfo html add-ref-resolver!}@defun add-ref-resolver! proc

doc/ref/web.texi

@@ -127,8 +127,8 @@ basic idea is that HTML is either text, represented by a string, or an
 element, represented as a tagged list.  So @samp{foo} becomes
 @samp{"foo"}, and @samp{<b>foo</b>} becomes @samp{(b "foo")}.
 Attributes, if present, go in a tagged list headed by @samp{@@}, like
-@samp{(img (@@ (src "http://example.com/foo.png")))}.  @xref{sxml
+@samp{(img (@@ (src "http://example.com/foo.png")))}.  @xref{SXML}, for
-simple}, for more information.
+more information.
 
 The good thing about SXML is that HTML elements cannot be confused with
 text.  Let's make a new definition of @code{para}:
@@ -1769,7 +1769,7 @@ message body is long enough.)
 The web handler interface is a common baseline that all kinds of Guile
 web applications can use.  You will usually want to build something on
 top of it, however, especially when producing HTML.  Here is a simple
-example that builds up HTML output using SXML (@pxref{sxml simple}).
+example that builds up HTML output using SXML (@pxref{SXML}).
 
 First, load up the modules:
 

libguile/memoize.c

@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- *   2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+ *   2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
  *   Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -910,7 +910,6 @@ void
 scm_init_memoize ()
 {
   scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
-  scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
   scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
 
   scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);

module/ice-9/psyntax-pp.scm

@@ -990,7 +990,7 @@
              (let ((e (cdar body)) (er (caar body)))
                (call-with-values
                  (lambda ()
-                   (syntax-type e er '(()) (source-annotation er) ribcage mod #f))
+                   (syntax-type e er '(()) (source-annotation e) ribcage mod #f))
                  (lambda (type value form e w s mod)
                    (let ((key type))
                      (cond ((memv key '(define-form))
@@ -1004,20 +1004,31 @@
                                        (cons var vars)
                                        (cons (cons er (wrap e w mod)) vals)
                                        (cons (cons 'lexical var) bindings)))))
-                           ((memv key '(define-syntax-form define-syntax-parameter-form))
+                           ((memv key '(define-syntax-form))
-                            (let ((id (wrap value w mod)) (label (gen-label)))
+                            (let ((id (wrap value w mod))
+                                  (label (gen-label))
+                                  (trans-r (macros-only-env er)))
                               (extend-ribcage! ribcage id label)
-                              (parse (cdr body)
+                              (set-cdr!
-                                     (cons id ids)
+                                r
-                                     (cons label labels)
+                                (extend-env
-                                     var-ids
+                                  (list label)
-                                     vars
+                                  (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
-                                     vals
+                                  (cdr r)))
-                                     (cons (cons (if (eq? type 'define-syntax-parameter-form)
+                              (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
-                                                   'syntax-parameter
+                           ((memv key '(define-syntax-parameter-form))
-                                                   'macro)
+                            (let ((id (wrap value w mod))
-                                                 (cons er (wrap e w mod)))
+                                  (label (gen-label))
-                                           bindings))))
+                                  (trans-r (macros-only-env er)))
+                              (extend-ribcage! ribcage id label)
+                              (set-cdr!
+                                r
+                                (extend-env
+                                  (list label)
+                                  (list (cons 'syntax-parameter
+                                              (list (eval-local-transformer (expand e trans-r w mod) mod))))
+                                  (cdr r)))
+                              (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
                            ((memv key '(begin-form))
                             (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
                               (if tmp
@@ -1067,18 +1078,6 @@
                                 #f
                                 "invalid or duplicate identifier in definition"
                                 outer-form))
-                            (let loop ((bs bindings) (er-cache #f) (r-cache #f))
-                              (if (not (null? bs))
-                                (let ((b (car bs)))
-                                  (if (memq (car b) '(macro syntax-parameter))
-                                    (let* ((er (cadr b))
-                                           (r-cache (if (eq? er er-cache) r-cache (macros-only-env er))))
-                                      (set-cdr!
-                                        b
-                                        (eval-local-transformer (expand (cddr b) r-cache '(()) mod) mod))
-                                      (if (eq? (car b) 'syntax-parameter) (set-cdr! b (list (cdr b))))
-                                      (loop (cdr bs) er r-cache))
-                                    (loop (cdr bs) er-cache r-cache)))))
                             (set-cdr! r (extend-env labels bindings (cdr r)))
                             (build-letrec
                               #f
@@ -3026,33 +3025,37 @@
     'macro
     (lambda (x)
       (letrec*
-        ((read-file
+        ((absolute-path? (lambda (path) (string-prefix? "/" path)))
-           (lambda (fn k)
+         (read-file
-             (let ((p (open-input-file fn)))
+           (lambda (fn dir k)
+             (let ((p (open-input-file (if (absolute-path? fn) fn (in-vicinity dir fn)))))
                (let f ((x (read p)) (result '()))
                  (if (eof-object? x)
                    (begin (close-input-port p) (reverse result))
                    (f (read p) (cons (datum->syntax k x) result))))))))
-        (let ((tmp-1 x))
+        (let ((src (syntax-source x)))
-          (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+          (let ((file (if src (assq-ref src 'filename) #f)))
-            (if tmp
+            (let ((dir (if (string? file) (dirname file) #f)))
-              (apply (lambda (k filename)
+              (let ((tmp-1 x))
-                       (let ((fn (syntax->datum filename)))
+                (let ((tmp ($sc-dispatch tmp-1 '(any any))))
-                         (let ((tmp-1 (read-file fn filename)))
+                  (if tmp
-                           (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                    (apply (lambda (k filename)
-                             (if tmp
+                             (let ((fn (syntax->datum filename)))
-                               (apply (lambda (exp)
+                               (let ((tmp-1 (read-file fn dir filename)))
-                                        (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
+                                 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
-                                      tmp)
+                                   (if tmp
-                               (syntax-violation
+                                     (apply (lambda (exp)
-                                 #f
+                                              (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
-                                 "source expression failed to match any pattern"
+                                            tmp)
-                                 tmp-1))))))
+                                     (syntax-violation
-                     tmp)
+                                       #f
-              (syntax-violation
+                                       "source expression failed to match any pattern"
-                #f
+                                       tmp-1))))))
-                "source expression failed to match any pattern"
+                           tmp)
-                tmp-1))))))))
+                    (syntax-violation
+                      #f
+                      "source expression failed to match any pattern"
+                      tmp-1)))))))))))
 
 (define include-from-path
   (make-syntax-transformer

module/ice-9/psyntax.scm

@@ -1531,7 +1531,7 @@
                 (syntax-violation #f "no expressions in body" outer-form)
                 (let ((e (cdar body)) (er (caar body)))
                   (call-with-values
-                      (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
+                      (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f))
                     (lambda (type value form e w s mod)
                       (case type
                         ((define-form)
@@ -1543,18 +1543,40 @@
                                     (cons id var-ids)
                                     (cons var vars) (cons (cons er (wrap e w mod)) vals)
                                     (cons (make-binding 'lexical var) bindings)))))
-                        ((define-syntax-form define-syntax-parameter-form)
+                        ((define-syntax-form)
-                         (let ((id (wrap value w mod)) (label (gen-label)))
+                         (let ((id (wrap value w mod))
+                               (label (gen-label))
+                               (trans-r (macros-only-env er)))
                            (extend-ribcage! ribcage id label)
-                           (parse (cdr body)
+                           ;; As required by R6RS, evaluate the right-hand-sides of internal
-                                  (cons id ids) (cons label labels)
+                           ;; syntax definition forms and add their transformers to the
-                                  var-ids vars vals
+                           ;; compile-time environment immediately, so that the newly-defined
-                                  (cons (make-binding
+                           ;; keywords may be used in definition context within the same
-                                         (if (eq? type 'define-syntax-parameter-form)
+                           ;; lexical contour.
-                                             'syntax-parameter
+                           (set-cdr! r (extend-env
-                                             'macro)
+                                        (list label)
-                                         (cons er (wrap e w mod)))
+                                        (list (make-binding
-                                        bindings))))
+                                               'macro
+                                               (eval-local-transformer
+                                                (expand e trans-r w mod)
+                                                mod)))
+                                        (cdr r)))
+                           (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+                        ((define-syntax-parameter-form)
+                         ;; Same as define-syntax-form, but different format of the binding.
+                         (let ((id (wrap value w mod))
+                               (label (gen-label))
+                               (trans-r (macros-only-env er)))
+                           (extend-ribcage! ribcage id label)
+                           (set-cdr! r (extend-env
+                                        (list label)
+                                        (list (make-binding
+                                               'syntax-parameter
+                                               (list (eval-local-transformer
+                                                      (expand e trans-r w mod)
+                                                      mod))))
+                                        (cdr r)))
+                           (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
                         ((begin-form)
                          (syntax-case e ()
                            ((_ e1 ...)
@@ -1585,23 +1607,6 @@
                                    (syntax-violation
                                     #f "invalid or duplicate identifier in definition"
                                     outer-form))
-                               (let loop ((bs bindings) (er-cache #f) (r-cache #f))
-                                 (if (not (null? bs))
-                                     (let* ((b (car bs)))
-                                       (if (memq (car b) '(macro syntax-parameter))
-                                           (let* ((er (cadr b))
-                                                  (r-cache
-                                                   (if (eq? er er-cache)
-                                                       r-cache
-                                                       (macros-only-env er))))
-                                             (set-cdr! b
-                                                       (eval-local-transformer
-                                                        (expand (cddr b) r-cache empty-wrap mod)
-                                                        mod))
-                                             (if (eq? (car b) 'syntax-parameter)
-                                                 (set-cdr! b (list (cdr b))))
-                                             (loop (cdr bs) er r-cache))
-                                           (loop (cdr bs) er-cache r-cache)))))
                                (set-cdr! r (extend-env labels bindings (cdr r)))
                                (build-letrec no-source #t
                                              (reverse (map syntax->datum var-ids))

module/language/assembly/spec.scm

@@ -1,6 +1,6 @@
 ;;; Guile Virtual Machine Assembly
 
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2013 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
@@ -31,4 +31,5 @@
   #:parser      read ;; fixme: make a verifier?
   #:compilers   `((bytecode . ,compile-bytecode))
   #:decompilers `((bytecode . ,decompile-bytecode))
+  #:for-humans? #f
   )

module/language/bytecode/spec.scm

@@ -1,6 +1,6 @@
 ;;; Guile Lowlevel Intermediate Language
 
-;; Copyright (C) 2001, 2009, 2010, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013 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
@@ -36,4 +36,5 @@
   #:printer	write
   #:compilers   `((objcode . ,compile-objcode))
   #:decompilers `((objcode . ,decompile-objcode))
+  #:for-humans? #f
   )

module/language/ecmascript/base.scm

@@ -1,6 +1,6 @@
 ;;; ECMAScript for Guile
 
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2013 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
@@ -168,7 +168,8 @@
       x))
 
 (define (->boolean x)
-  (not (or (not x) (null? x) (eq? x *undefined*) (zero? x) (nan? x)
+  (not (or (not x) (null? x) (eq? x *undefined*)
+           (and (number? x) (or (zero? x) (nan? x)))
            (and (string? x) (= (string-length x) 0)))))
 
 (define (->number x)

module/language/glil/spec.scm

@@ -1,6 +1,6 @@
 ;;; Guile Lowlevel Intermediate Language
 
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2013 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
@@ -37,4 +37,6 @@
   #:printer	write-glil
   #:parser      parse-glil
   #:compilers   `((assembly . ,compile-asm))
-  #:decompilers `((assembly . ,decompile-assembly)))
+  #:decompilers `((assembly . ,decompile-assembly))
+  #:for-humans? #f
+  )

module/language/objcode/spec.scm

@@ -1,6 +1,6 @@
 ;;; Guile Lowlevel Intermediate Language
 
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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
@@ -80,4 +80,5 @@
   #:printer	write-objcode
   #:compilers   `((value . ,objcode->value))
   #:decompilers `((value . ,decompile-value))
+  #:for-humans? #f
   )

module/language/tree-il/analyze.scm

@@ -1265,11 +1265,11 @@ accurate information is missing from a given `tree-il' element."
         (case state
           ((tilde)
            (case (car chars)
-             ((#\~ #\% #\& #\t #\_ #\newline #\( #\))
+             ((#\~ #\% #\& #\t #\T #\_ #\newline #\( #\) #\! #\| #\/ #\q #\Q)
                         (loop (cdr chars) 'literal '()
                               conditions end-group
                               min-count max-count))
-             ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\, #\: #\@)
+             ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\, #\: #\@ #\+ #\- #\#)
                         (loop (cdr chars)
                               'tilde (cons (car chars) params)
                               conditions end-group
@@ -1336,16 +1336,23 @@ accurate information is missing from a given `tree-il' element."
                                      min-count)
                                   (+ (or (previous-number params) 1)
                                      max-count))))
-             ((#\? #\k)
+             ((#\? #\k #\K)
               ;; We don't have enough info to determine the exact number
               ;; of args, but we could determine a lower bound (TODO).
               (values 'any 'any))
+             ((#\^)
+              (values min-count 'any))
              ((#\h #\H)
                         (let ((argc (if (memq #\: params) 2 1)))
                           (loop (cdr chars) 'literal '()
                                 conditions end-group
                                 (+ argc min-count)
                                 (+ argc max-count))))
+             ((#\')
+              (if (null? (cdr chars))
+                  (throw &syntax-error 'unexpected-termination)
+                  (loop (cddr chars) 'tilde (cons (cadr chars) params)
+                        conditions end-group min-count max-count)))
              (else      (loop (cdr chars) 'literal '()
                               conditions end-group
                               (+ 1 min-count) (+ 1 max-count)))))

module/language/tree-il/spec.scm

@@ -1,6 +1,6 @@
 ;;; Tree Intermediate Language
 
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013 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
@@ -44,4 +44,5 @@
   #:parser      parse-tree-il
   #:joiner      join
   #:compilers   `((glil . ,compile-glil))
+  #:for-humans? #f
   )

module/language/value/spec.scm

@@ -1,6 +1,6 @@
 ;;; Guile Lowlevel Intermediate Language
 
-;; Copyright (C) 2001, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 2013 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
@@ -26,4 +26,5 @@
   #:title	"Values"
   #:reader	#f
   #:printer	write
+  #:for-humans? #f
   )

module/oop/goops.scm

@@ -1,28 +1,27 @@
 ;;; installed-scm-file
 
 ;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
-;;;; 
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
 ;;;; This library 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.
-;;;; 
+;;;;
 ;;;; This library 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 library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;; 
+;;;;
 
 
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
 ;;;;
-;;;; This file is based upon stklos.stk from the STk distribution by
+;;;; This file was based upon stklos.stk from the STk distribution
-;;;; Erick Gallesio <eg@unice.fr>.
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
 ;;;;
 
 (define-module (oop goops)

module/oop/goops/active-slot.scm

@@ -1,28 +1,27 @@
 ;;; installed-scm-file
 
-;;;; 	Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2006, 2009 Free Software Foundation, Inc.
-;;;; 
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
 ;;;; This library 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.
-;;;; 
+;;;;
 ;;;; This library 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 library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;; 
-
-
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
 ;;;;
-;;;; This file is based upon active-slot.stklos from the STk
+
-;;;; distribution by Erick Gallesio <eg@unice.fr>.
+
+;;;;
+;;;; This file was based upon active-slot.stklos from the STk distribution
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
 ;;;;
 
 (define-module (oop goops active-slot)

module/oop/goops/composite-slot.scm

@@ -1,28 +1,27 @@
 ;;; installed-scm-file
 
-;;;; 	Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
-;;;; 
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
 ;;;; This library 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.
-;;;; 
+;;;;
 ;;;; This library 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 library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;; 
+;;;;
 
 
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
 ;;;;
-;;;; This file is based upon composite-slot.stklos from the STk
+;;;; This file was based upon composite-slot.stklos from the STk distribution
-;;;; distribution by Erick Gallesio <eg@unice.fr>.
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
 ;;;;
 
 (define-module (oop goops composite-slot)

module/oop/goops/describe.scm

@@ -1,28 +1,27 @@
 ;;; installed-scm-file
 
-;;;; 	Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
-;;;; 
+;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;;
 ;;;; This library 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.
-;;;; 
+;;;;
 ;;;; This library 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 library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;; 
+;;;;
 
 
-;;;; This software is a derivative work of other copyrighted softwares; the
-;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
 ;;;;
-;;;; This file is based upon describe.stklos from the STk distribution by
+;;;; This file was based upon describe.stklos from the STk distribution
-;;;; Erick Gallesio <eg@unice.fr>.
+;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
 ;;;;
 
 (define-module (oop goops describe)

module/oop/goops/save.scm

@@ -127,6 +127,29 @@
 (define (readable? obj)
   (hashq-ref readables obj))
 
+;;;
+;;; Writer helpers
+;;;
+
+(define (write-component-procedure o file env)
+  "Return #f if circular reference"
+  (cond ((immediate? o) (write o file) #t)
+	((readable? o) (write (readable-expression o) file) #t)
+	((excluded? o env) (display #f file) #t)
+	(else
+	 (let ((info (object-info o env)))
+	   (cond ((not (binding? info)) (write-readably o file env) #t)
+		 ((not (eq? (visiting info) #:defined)) #f) ;forward reference
+		 (else (display (binding info) file) #t))))))
+
+;;; write-component OBJECT PATCHER FILE ENV
+;;;
+(define-macro (write-component object patcher file env)
+  `(or (write-component-procedure ,object ,file ,env)
+       (begin
+         (display #f ,file)
+         (add-patcher! ,patcher ,env))))
+
 ;;;
 ;;; Strings
 ;;;
@@ -603,24 +626,6 @@
 	   (pop-ref! env)
 	   (set! (objects env) (cons o (objects env)))))))
 
-(define (write-component-procedure o file env)
-  "Return #f if circular reference"
-  (cond ((immediate? o) (write o file) #t)
-	((readable? o) (write (readable-expression o) file) #t)
-	((excluded? o env) (display #f file) #t)
-	(else
-	 (let ((info (object-info o env)))
-	   (cond ((not (binding? info)) (write-readably o file env) #t)
-		 ((not (eq? (visiting info) #:defined)) #f) ;forward reference
-		 (else (display (binding info) file) #t))))))
-
-;;; write-component OBJECT PATCHER FILE ENV
-;;;
-(define-macro (write-component object patcher file env)
-  `(or (write-component-procedure ,object ,file ,env)
-       (begin
-         (display #f ,file)
-         (add-patcher! ,patcher ,env))))
 
 ;;;
 ;;; Main engine

module/sxml/simple.scm

@@ -1,6 +1,6 @@
 ;;;; (sxml simple) -- a simple interface to the SSAX parser
 ;;;;
-;;;; 	Copyright (C) 2009, 2010  Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2013  Free Software Foundation, Inc.
 ;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
 ;;;;    Originally written by Oleg Kiselyov <oleg at pobox dot com> as SXML-to-HTML.scm.
 ;;;; 
@@ -26,16 +26,194 @@
 ;;; Code:
 
 (define-module (sxml simple)
+  #:use-module (sxml ssax input-parse)
   #:use-module (sxml ssax)
   #:use-module (sxml transform)
-  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 match)
   #:use-module (srfi srfi-13)
   #:export (xml->sxml sxml->xml sxml->string))
 
-(define* (xml->sxml #:optional (port (current-input-port)))
+;; Helpers from upstream/SSAX.scm.
+;;
+
+;     ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS
+; given the list of fragments (some of which are text strings)
+; reverse the list and concatenate adjacent text strings.
+; We can prove from the general case below that if LIST-OF-FRAGS
+; has zero or one element, the result of the procedure is equal?
+; to its argument. This fact justifies the shortcut evaluation below.
+(define (ssax:reverse-collect-str fragments)
+  (cond
+    ((null? fragments) '())	; a shortcut
+    ((null? (cdr fragments)) fragments) ; see the comment above
+    (else
+      (let loop ((fragments fragments) (result '()) (strs '()))
+	(cond
+	  ((null? fragments)
+	    (if (null? strs) result
+	      (cons (string-concatenate/shared strs) result)))
+	  ((string? (car fragments))
+	    (loop (cdr fragments) result (cons (car fragments) strs)))
+	  (else
+	    (loop (cdr fragments)
+	      (cons
+		(car fragments)
+		(if (null? strs) result
+		  (cons (string-concatenate/shared strs) result)))
+	      '())))))))
+
+(define (read-internal-doctype-as-string port)
+  (string-concatenate/shared
+    (let loop ()
+      (let ((fragment
+	     (next-token '() '(#\]) "reading internal DOCTYPE" port)))
+	(if (eqv? #\> (peek-next-char port))
+	    (begin
+	      (read-char port)
+	      (cons fragment '()))
+	    (cons* fragment "]" (loop)))))))
+
+;; Ideas for the future for this interface:
+;;
+;;  * Allow doctypes to provide parsed entities
+;;
+;;  * Allow validation (the ELEMENTS value from the DOCTYPE handler
+;;    below)
+;;
+;;  * Parse internal DTDs
+;;
+;;  * Parse external DTDs
+;;
+(define* (xml->sxml #:optional (string-or-port (current-input-port)) #:key
+                    (namespaces '())
+                    (declare-namespaces? #t)
+                    (trim-whitespace? #f)
+                    (entities '())
+                    (default-entity-handler #f)
+                    (doctype-handler #f))
   "Use SSAX to parse an XML document into SXML. Takes one optional
-argument, @var{port}, which defaults to the current input port."
+argument, @var{string-or-port}, which defaults to the current input
-  (ssax:xml->sxml port '()))
+port."
+  ;; NAMESPACES: alist of PREFIX -> URI.  Specifies the symbol prefix
+  ;; that the user wants on elements of a given namespace in the
+  ;; resulting SXML, regardless of the abbreviated namespaces defined in
+  ;; the document by xmlns attributes.  If DECLARE-NAMESPACES? is true,
+  ;; these namespaces are treated as if they were declared in the DTD.
+
+  ;; ENTITIES: alist of SYMBOL -> STRING.
+
+  ;; NAMESPACES: list of (DOC-PREFIX . (USER-PREFIX . URI)).
+  ;; A DOC-PREFIX of #f indicates that it comes from the user.
+  ;; Otherwise, prefixes are symbols.
+  (define (munge-namespaces namespaces)
+    (map (lambda (el)
+           (match el
+             ((prefix . uri-string)
+              (cons* (and declare-namespaces? prefix)
+                     prefix
+                     (ssax:uri-string->symbol uri-string)))))
+         namespaces))
+
+  (define (user-namespaces)
+    (munge-namespaces namespaces))
+
+  (define (user-entities)
+    (if (and default-entity-handler
+             (not (assq '*DEFAULT* entities)))
+        (acons '*DEFAULT* default-entity-handler entities)
+        entities))
+
+  (define (name->sxml name)
+    (match name
+      ((prefix . local-part)
+       (symbol-append prefix (string->symbol ":") local-part))
+      (_ name)))
+
+  (define (doctype-continuation seed)
+    (lambda* (#:key (entities '()) (namespaces '()))
+      (values #f
+              (append entities (user-entities))
+              (append (munge-namespaces namespaces) (user-namespaces))
+              seed)))
+
+  ;; The SEED in this parser is the SXML: initialized to '() at each new
+  ;; level by the fdown handlers; built in reverse by the fhere parsers;
+  ;; and reverse-collected by the fup handlers.
+  (define parser
+    (ssax:make-parser
+     NEW-LEVEL-SEED ; fdown
+     (lambda (elem-gi attributes namespaces expected-content seed)
+       '())
+   
+     FINISH-ELEMENT ; fup
+     (lambda (elem-gi attributes namespaces parent-seed seed)
+       (let ((seed (if trim-whitespace?
+                       (ssax:reverse-collect-str-drop-ws seed)
+                       (ssax:reverse-collect-str seed)))
+             (attrs (attlist-fold
+                     (lambda (attr accum)
+                       (cons (list (name->sxml (car attr)) (cdr attr))
+                             accum))
+                     '() attributes)))
+         (acons (name->sxml elem-gi)
+                (if (null? attrs)
+                    seed
+                    (cons (cons '@ attrs) seed))
+                parent-seed)))
+
+     CHAR-DATA-HANDLER ; fhere
+     (lambda (string1 string2 seed)
+       (if (string-null? string2)
+           (cons string1 seed)
+           (cons* string2 string1 seed)))
+
+     DOCTYPE
+     ;; -> ELEMS ENTITIES NAMESPACES SEED
+     ;;
+     ;; ELEMS is for validation and currently unused.
+     ;;
+     ;; ENTITIES is an alist of parsed entities (symbol -> string).
+     ;;
+     ;; NAMESPACES is as above.
+     ;;
+     ;; SEED builds up the content.
+     (lambda (port docname systemid internal-subset? seed)
+       (call-with-values
+           (lambda ()
+             (cond
+              (doctype-handler
+               (doctype-handler docname systemid
+                                (and internal-subset?
+                                     (read-internal-doctype-as-string port))))
+              (else
+               (when internal-subset?
+                 (ssax:skip-internal-dtd port))
+               (values))))
+         (doctype-continuation seed)))
+
+     UNDECL-ROOT
+     ;; This is like the DOCTYPE handler, but for documents that do not
+     ;; have a <!DOCTYPE!> entry.
+     (lambda (elem-gi seed)
+       (call-with-values
+           (lambda ()
+             (if doctype-handler
+                 (doctype-handler #f #f #f)
+                 (values)))
+        (doctype-continuation seed)))
+
+     PI
+     ((*DEFAULT*
+       . (lambda (port pi-tag seed)
+           (cons
+            (list '*PI* pi-tag (ssax:read-pi-body-as-string port))
+            seed))))))
+
+  (let* ((port (if (string? string-or-port)
+                   (open-input-string string-or-port)
+                   string-or-port))
+         (elements (reverse (parser port '()))))
+    `(*TOP* ,@elements)))
 
 (define check-name
   (let ((*good-cache* (make-hash-table)))

module/sxml/ssax.scm

@@ -1,6 +1,6 @@
 ;;;; (sxml ssax) -- the SSAX parser
 ;;;;
-;;;; 	Copyright (C) 2009, 2010,2012  Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010,2012,2013  Free Software Foundation, Inc.
 ;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
 ;;;;    Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com> as SSAX.scm.
 ;;;; 
@@ -170,17 +170,22 @@
 (define ascii->char integer->char)
 (define char->ascii char->integer)
 
-(define *current-ssax-error-port* (make-fluid))
+(define current-ssax-error-port
-(define (current-ssax-error-port)
+  (make-parameter (current-error-port)))
-  (fluid-ref *current-ssax-error-port*))
+
+(define *current-ssax-error-port*
+  (parameter-fluid current-ssax-error-port))
 
 (define (with-ssax-error-to-port port thunk)
-  (with-fluids ((*current-ssax-error-port* port))
+  (parameterize ((current-ssax-error-port port))
     (thunk)))
 
-(define (ssax:warn port msg . args)
+(define (ssax:warn port . args)
-  (format (current-ssax-error-port)
+  (with-output-to-port (current-ssax-error-port)
-          ";;; SSAX warning: ~a ~a\n" msg args))
+    (lambda ()
+      (display ";;; SSAX warning: ")
+      (for-each display args)
+      (newline))))
 
 (define (ucscode->string codepoint)
   (string (integer->char codepoint)))

module/sxml/upstream/SSAX.scm

@@ -442,6 +442,11 @@
 ;	named-entity-name is currently being expanded. A reference to
 ;	this named-entity-name will be an error: violation of the
 ;	WFC nonrecursion.
+;
+;       As an extension to the original SSAX, Guile allows a
+;       named-entity-name of *DEFAULT* to indicate a fallback procedure,
+;       called as (FALLBACK PORT NAME).  The procedure should return a
+;       string.
 
 ; XML-TOKEN -- a record
 
@@ -1095,10 +1100,20 @@
 	     (close-input-port port))))
 	 (else
 	  (parser-error port "[norecursion] broken for " name))))))
-    ((assq name ssax:predefined-parsed-entities)
+   ((assq name ssax:predefined-parsed-entities)
-     => (lambda (decl-entity)
+    => (lambda (decl-entity)
-	  (str-handler (cdr decl-entity) "" seed)))
+         (str-handler (cdr decl-entity) "" seed)))
-    (else (parser-error port "[wf-entdeclared] broken for " name))))
+   ((assq '*DEFAULT* entities) =>
+    (lambda (decl-entity)
+      (let ((fallback (cdr decl-entity))
+	    (new-entities (cons (cons name #f) entities)))
+	(cond
+	 ((procedure? fallback)
+          (call-with-input-string (fallback port name)
+	     (lambda (port) (content-handler port new-entities seed))))
+	 (else
+	  (parser-error port "[norecursion] broken for " name))))))
+   (else (parser-error port "[wf-entdeclared] broken for " name))))
 
 
 
@@ -1267,6 +1282,14 @@
 	  '((ent . "<&ent1;T;>") (ent1 . "&"))
 	  `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
 	    (,(string->symbol "Next") . "12<&T;>34")))
+    (test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
+	  `((*DEFAULT* . ,(lambda (port name)
+                            (case name
+                              ((ent) "&lt;&ent1;T;&gt;")
+                              ((ent1) "&amp;")
+                              (else (error "unrecognized" name))))))
+	  `((,(string->symbol "Abc") . ,(unesc-string "<&>%n"))
+	    (,(string->symbol "Next") . "12<&T;>34")))
     (assert (failed?
 	(test "%tAbc='&lt;&amp;&gt;&#x0A;'%nNext='12&ent;34' />" 
 	  '((ent . "<&ent1;T;&gt;") (ent1 . "&amp;")) '())))

module/system/base/language.scm

@@ -25,7 +25,8 @@
             language-name language-title language-reader
             language-printer language-parser 
             language-compilers language-decompilers language-evaluator
-            language-joiner language-make-default-environment
+            language-joiner language-for-humans?
+            language-make-default-environment
 
             lookup-compilation-order lookup-decompilation-order
             invalidate-compilation-cache! default-environment
@@ -49,6 +50,7 @@
   (decompilers '())
   (evaluator #f)
   (joiner #f)
+  (for-humans? #t)
   (make-default-environment make-fresh-user-module))
 
 (define-macro (define-language name . spec)

module/system/repl/common.scm

@@ -1,6 +1,7 @@
 ;;; Repl common routines
 
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
+;;    2013 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
@@ -39,7 +40,7 @@
 
 (define *version*
   (format #f "GNU Guile ~A
-Copyright (C) 1995-2012 Free Software Foundation, Inc.
+Copyright (C) 1995-2013 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

test-suite/standalone/Makefile.am

@@ -1,7 +1,7 @@
 ## Process this file with automake to produce Makefile.in.
 ##
 ## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-##   2011, 2012 Free Software Foundation, Inc.
+##   2011, 2012, 2013 Free Software Foundation, Inc.
 ##
 ## This file is part of GUILE.
 ##
@@ -31,6 +31,7 @@ BUILT_SOURCES =
 EXTRA_DIST =
 
 TESTS_ENVIRONMENT =						\
+  top_srcdir="$(top_srcdir)"					\
   srcdir="$(srcdir)"						\
   builddir="$(builddir)"					\
   @LOCALCHARSET_TESTS_ENVIRONMENT@				\
@@ -88,6 +89,10 @@ TESTS += test-command-line-encoding
 check_SCRIPTS += test-command-line-encoding2
 TESTS += test-command-line-encoding2
 
+check_SCRIPTS += test-language
+TESTS += test-language
+EXTRA_DIST += test-language.el test-language.js
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}

test-suite/standalone/test-language

@@ -0,0 +1,25 @@
+#!/bin/sh
+
+set -e
+
+# Make sure that code passed as `-c' or `-l' is evaluted using the
+# right language.
+
+# The default language in effect until `--language' is encountered is
+# Scheme.
+guile -c "(exit (= 3 (apply + '(1 2))))" --language=elisp
+! guile -c "(= (funcall (symbol-function '+) 1 2) 3)" 2> /dev/null
+
+guile --language=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)"
+guile --language=ecmascript -c '(function (x) { return x * x; })(2);'
+
+# Same with `-l'.
+guile --no-auto-compile -l "$top_srcdir/module/ice-9/q.scm" -c 1
+guile --no-auto-compile				\
+      -l "$top_srcdir/module/ice-9/q.scm"	\
+      --language=elisp				\
+      -l "$srcdir/test-language.el"		\
+      --language=ecmascript			\
+      -l "$srcdir/test-language.js"		\
+      --language=scheme				\
+      -c 1

test-suite/standalone/test-language.el

@@ -0,0 +1,11 @@
+;; Sample Elisp code for `test-language'.
+
+(defun fib (n)
+  "Anything but a fib."
+  (if (<= n 1)
+      n
+    (+ (fib (- n 1))
+       (fib (- n 2)))))
+
+(or (= 13 (fib 7))
+    (error "Something's wrong!"))

test-suite/standalone/test-language.js

@@ -0,0 +1,12 @@
+/* Sample ECMAscript code for `test-language'.  */
+
+function fib (n)
+{
+    if (n <= 1)
+	return n;
+    else
+	return fib (n - 1) + fib (n - 2);
+}
+
+if (fib (7) != 13)
+    error ("Something's wrong!");

test-suite/tests/ecmascript.test

@@ -80,6 +80,7 @@
 (with-test-prefix "compiler"
 
   (ecompile "true;" #t)
+  (ecompile "if (3 > 2) true; else false;" #t)
   (ecompile "2 + 2;" 4)
   (ecompile "\"hello\";" "hello")
   (ecompile "var test = { bar: 1 };")

test-suite/tests/sxml.simple.test

@@ -1,6 +1,6 @@
 ;;;; sxml.simple.test --- (sxml simple)  -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2010, 2013 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
@@ -20,6 +20,8 @@
   #:use-module (test-suite lib)
   #:use-module (sxml simple))
 
+(define parser-error '(parser-error . ""))
+
 (define %xml-sample
   ;; An XML sample without any space in between tags, to make it easier.
   (string-append "<?xml version='1.0' encoding='utf-8'?>"
@@ -50,3 +52,84 @@
                 (lambda ()
                   (sxml->xml
                    (xml->sxml (open-input-string %xml-sample))))))))))
+
+(with-test-prefix "namespaces"
+  (pass-if-equal
+      (xml->sxml "<foo xmlns=\"http://example.org/ns1\">text</foo>")
+      '(*TOP* (http://example.org/ns1:foo "text")))
+
+  (pass-if-equal
+      (xml->sxml "<foo xmlns=\"http://example.org/ns1\">text</foo>"
+                 #:namespaces '((ns1 . "http://example.org/ns1")))
+      '(*TOP* (ns1:foo "text")))
+
+  (pass-if-equal
+      (xml->sxml "<foo xmlns:bar=\"http://example.org/ns2\"><bar:baz/></foo>"
+                 #:namespaces '((ns2 . "http://example.org/ns2")))
+      '(*TOP* (foo (ns2:baz))))
+
+  (pass-if-equal
+      (xml->sxml "<foo><ns2:baz/></foo>"
+                 #:namespaces '((ns2 . "http://example.org/ns2")))
+      '(*TOP* (foo (ns2:baz))))
+
+  (pass-if-exception "namespace undeclared" parser-error
+    (xml->sxml "<foo><ns2:baz/></foo>"
+               #:namespaces '((ns2 . "http://example.org/ns2"))
+               #:declare-namespaces? #f)))
+
+(with-test-prefix "whitespace"
+  (pass-if-equal
+      (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>")
+      '(*TOP* (foo "\n" (bar " Alfie the parrot! ") "\n")))
+
+  (pass-if-equal
+      (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>"
+                 #:trim-whitespace? #t)
+      '(*TOP* (foo (bar " Alfie the parrot! ")))))
+
+(with-test-prefix "parsed entities"
+  (pass-if-equal
+      '(*TOP* (foo "&"))
+      (xml->sxml "<foo>&amp;</foo>"))
+
+  (pass-if-exception "nbsp undefined" parser-error
+    (xml->sxml "<foo>&nbsp;</foo>"))
+
+  (pass-if-equal
+      '(*TOP* (foo "\xA0"))
+      (xml->sxml "<foo>&nbsp;</foo>"
+                 #:entities '((nbsp . "\xA0"))))
+
+  (pass-if-equal
+      '(*TOP* (foo "\xA0"))
+      (xml->sxml "<foo>&#xA0;</foo>"))
+
+  (let ((ents '()))
+    (pass-if-equal
+        (xml->sxml "<foo>&nbsp; &foo;</foo>"
+                   #:default-entity-handler
+                   (lambda (port name)
+                     (case name
+                       ((nbsp) "\xa0")
+                       (else
+                        (set! ents (cons name ents))
+                        "qux"))))
+        '(*TOP* (foo "\xa0 qux")))
+
+    (pass-if-equal
+        ents
+        '(foo))))
+
+(with-test-prefix "doctype handlers"
+  (define (handle-foo docname systemid internal-subset)
+    (case docname
+      ((foo)
+       (values #:entities '((greets . "<i>Hello, world!</i>"))))
+      (else
+       (values))))
+
+  (pass-if-equal
+      (xml->sxml "<!DOCTYPE foo><p>&greets;</p>"
+                 #:doctype-handler handle-foo)
+      '(*TOP* (p (i "Hello, world!")))))

test-suite/tests/tree-il.test

@@ -1415,11 +1415,11 @@
               (number? (string-contains (car w)
                                         "wrong number of arguments")))))
 
-     (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
+     (pass-if "~%, ~~, ~&, ~t, ~_, ~!, ~|, ~/, ~q and ~\\n"
        (null? (call-with-warnings
                (lambda ()
                  (compile '((@ (ice-9 format) format) some-port
-                            "~&~3_~~ ~\n~12they~%")
+                            "~&~3_~~ ~\n~12they~% ~!~|~/~q")
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
@@ -1687,6 +1687,31 @@
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
+     (pass-if "~^"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "~^, too few args"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "expected at least 1, got 0")))))
+
+     (pass-if "parameters: +,-,#, and '"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '((@ (ice-9 format) format) some-port
+                            "~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
      (pass-if "complex 1"
        (let ((w (call-with-warnings
                  (lambda ()