mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

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

Browse source 
Conflicts:
	module/ice-9/psyntax-pp.scm
	module/ice-9/psyntax.scm
	module/language/bytecode/spec.scm
	module/language/tree-il/spec.scm
This commit is contained in:
Andy Wingo 2013-01-31 11:52:42 +01:00
commit 180ac9d7b0
35 changed files with 1293 additions and 707 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

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

9
configure.ac
View file

@ -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.
AM_INIT_AUTOMAKE([1.11.2 gnu no-define -Wall -Wno-override color-tests dist-xz])
dnl Use `serial-tests' so the output `check-guile' is not hidden
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)

3
doc/ref/compiler.texi
View file

@ -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}

10
doc/ref/sxml-match.texi
View file

@ -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
SXML trees, in a ``by example'' style reminiscent of the pattern matching of the
@code{syntax-rules} and @code{syntax-case} macro systems. @xref{sxml simple,
the @code{(sxml simple)} module}, for more information on SXML.
The @code{(sxml match)} module provides syntactic forms for pattern
matching of SXML trees, in a ``by example'' style reminiscent of the
pattern matching of the @code{syntax-rules} and @code{syntax-case} macro
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

1150
doc/ref/sxml.texi
View file

File diff suppressed because it is too large Load diff

14
doc/ref/texinfo.texi
View file

@ -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,
this function returns an untagged list of stexi elements.
Returns a nodeset; that is to say, 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
sxml->xml,sxml->xml}. 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!}, for more information.
that it must eventually be serialized by @code{sxml->xml}.
@xref{Reading and Writing XML}.
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

6
doc/ref/web.texi
View file

@ -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
simple}, for more information.
@samp{(img (@@ (src "http://example.com/foo.png")))}. @xref{SXML}, for
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:

3
libguile/memoize.c
View file

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

65
module/ice-9/psyntax-pp.scm
View file

@ -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))
(let ((id (wrap value w mod)) (label (gen-label)))
((memv key '(define-syntax-form))
(let ((id (wrap value w mod))
(label (gen-label))
(trans-r (macros-only-env er)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids)
(cons label labels)
var-ids
vars
vals
(cons (cons (if (eq? type 'define-syntax-parameter-form)
'syntax-parameter
'macro)
(cons er (wrap e w mod)))
bindings))))
(set-cdr!
r
(extend-env
(list label)
(list (cons '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)))
((memv key '(define-syntax-parameter-form))
(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 (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,19 +3025,23 @@
'macro
(lambda (x)
(letrec*
((read-file
(lambda (fn k)
(let ((p (open-input-file fn)))
((absolute-path? (lambda (path) (string-prefix? "/" path)))
(read-file
(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 ((src (syntax-source x)))
(let ((file (if src (assq-ref src 'filename) #f)))
(let ((dir (if (string? file) (dirname file) #f)))
(let ((tmp-1 x))
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp
(apply (lambda (k filename)
(let ((fn (syntax->datum filename)))
(let ((tmp-1 (read-file fn filename)))
(let ((tmp-1 (read-file fn dir filename)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
(apply (lambda (exp)
@ -3052,7 +3055,7 @@
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1))))))))
tmp-1)))))))))))
(define include-from-path
(make-syntax-transformer

61
module/ice-9/psyntax.scm
View file

@ -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)
(let ((id (wrap value w mod)) (label (gen-label)))
((define-syntax-form)
(let ((id (wrap value w mod))
(label (gen-label))
(trans-r (macros-only-env er)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
var-ids vars vals
(cons (make-binding
(if (eq? type 'define-syntax-parameter-form)
;; As required by R6RS, evaluate the right-hand-sides of internal
;; syntax definition forms and add their transformers to the
;; compile-time environment immediately, so that the newly-defined
;; keywords may be used in definition context within the same
;; lexical contour.
(set-cdr! r (extend-env
(list label)
(list (make-binding
'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
'macro)
(cons er (wrap e w mod)))
bindings))))
(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))

3
module/language/assembly/spec.scm
View file

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

3
module/language/bytecode/spec.scm
View file

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

5
module/language/ecmascript/base.scm
View file

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

6
module/language/glil/spec.scm
View file

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

3
module/language/objcode/spec.scm
View file

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

13
module/language/tree-il/analyze.scm
View file

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

3
module/language/tree-il/spec.scm
View file

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

3
module/language/value/spec.scm
View file

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

7
module/oop/goops.scm
View file

@ -1,6 +1,7 @@
;;; 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
@ -18,11 +19,9 @@
;;;;
;;;; 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
;;;; Erick Gallesio <eg@unice.fr>.
;;;; This file was based upon stklos.stk from the STk distribution
;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
;;;;
(define-module (oop goops)

9
module/oop/goops/active-slot.scm
View file

@ -1,6 +1,7 @@
;;; installed-scm-file
;;;; 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
@ -16,13 +17,11 @@
;;;; 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)

7
module/oop/goops/composite-slot.scm
View file

@ -1,6 +1,7 @@
;;; installed-scm-file
;;;; 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
@ -18,11 +19,9 @@
;;;;
;;;; 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
;;;; distribution by Erick Gallesio <eg@unice.fr>.
;;;; This file was based upon composite-slot.stklos from the STk distribution
;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
;;;;
(define-module (oop goops composite-slot)

7
module/oop/goops/describe.scm
View file

@ -1,6 +1,7 @@
;;; installed-scm-file
;;;; 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
@ -18,11 +19,9 @@
;;;;
;;;; 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
;;;; Erick Gallesio <eg@unice.fr>.
;;;; This file was based upon describe.stklos from the STk distribution
;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
;;;;
(define-module (oop goops describe)

41
module/oop/goops/save.scm
View file

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

188
module/sxml/simple.scm
View file

@ -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."
(ssax:xml->sxml port '()))
argument, @var{string-or-port}, which defaults to the current input
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)))

21
module/sxml/ssax.scm
View file

@ -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)
(fluid-ref *current-ssax-error-port*))
(define current-ssax-error-port
(make-parameter (current-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)
(format (current-ssax-error-port)
";;; SSAX warning: ~a ~a\n" msg args))
(define (ssax:warn port . args)
(with-output-to-port (current-ssax-error-port)
(lambda ()
(display ";;; SSAX warning: ")
(for-each display args)
(newline))))
(define (ucscode->string codepoint)
(string (integer->char codepoint)))

23
module/sxml/upstream/SSAX.scm
View file

@ -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
@ -1098,6 +1103,16 @@
((assq name ssax:predefined-parsed-entities)
=> (lambda (decl-entity)
(str-handler (cdr decl-entity) "" seed)))
((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 . "&lt;&ent1;T;&gt;") (ent1 . "&amp;"))
`((,(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;")) '())))

4
module/system/base/language.scm
View file

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

5
module/system/repl/common.scm
View file

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

7
test-suite/standalone/Makefile.am
View file

@ -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}

25
test-suite/standalone/test-language Executable file
View file

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

11
test-suite/standalone/test-language.el Normal file
View file

@ -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!"))

12
test-suite/standalone/test-language.js Normal file
View file

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

1
test-suite/tests/ecmascript.test
View file

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

85
test-suite/tests/sxml.simple.test
View file

@ -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!")))))

29
test-suite/tests/tree-il.test
View file

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