summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/psyntax-pp.scm101
-rw-r--r--module/ice-9/psyntax.scm63
-rw-r--r--module/language/assembly/spec.scm3
-rw-r--r--module/language/bytecode/spec.scm3
-rw-r--r--module/language/ecmascript/base.scm5
-rw-r--r--module/language/glil/spec.scm6
-rw-r--r--module/language/objcode/spec.scm3
-rw-r--r--module/language/tree-il/analyze.scm13
-rw-r--r--module/language/tree-il/spec.scm3
-rw-r--r--module/language/value/spec.scm3
-rw-r--r--module/oop/goops.scm15
-rw-r--r--module/oop/goops/active-slot.scm19
-rw-r--r--module/oop/goops/composite-slot.scm17
-rw-r--r--module/oop/goops/describe.scm17
-rw-r--r--module/oop/goops/save.scm41
-rw-r--r--module/sxml/simple.scm188
-rw-r--r--module/sxml/ssax.scm21
-rw-r--r--module/sxml/upstream/SSAX.scm31
-rw-r--r--module/system/base/language.scm4
-rw-r--r--module/system/repl/common.scm5
20 files changed, 397 insertions, 164 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 5c393402b..e330423b5 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/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))
- (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,33 +3025,37 @@
'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 ((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 ($sc-dispatch tmp-1 'each-any)))
- (if tmp
- (apply (lambda (exp)
- (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))))))
+ (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 dir filename)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (exp)
+ (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))))
(define include-from-path
(make-syntax-transformer
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 1698a024b..79f2fd41f 100644
--- a/module/ice-9/psyntax.scm
+++ b/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)
- (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)
+ ;; 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)
- (parse (cdr body)
- (cons id ids) (cons label labels)
- var-ids vars vals
- (cons (make-binding
- (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 (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))
diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm
index 01a55c4e1..0a497e4cf 100644
--- a/module/language/assembly/spec.scm
+++ b/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
)
diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm
index c2a6d46ab..ca703c33c 100644
--- a/module/language/bytecode/spec.scm
+++ b/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
)
diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm
index 6f5c65ba5..ac8493dd0 100644
--- a/module/language/ecmascript/base.scm
+++ b/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)
diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm
index a8164e5e4..3679e2166 100644
--- a/module/language/glil/spec.scm
+++ b/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
+ )
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 022419e9d..16f52410a 100644
--- a/module/language/objcode/spec.scm
+++ b/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
)
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 4af7998ab..f5890b25a 100644
--- a/module/language/tree-il/analyze.scm
+++ b/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)))))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 3ad372709..80c32fe29 100644
--- a/module/language/tree-il/spec.scm
+++ b/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
)
diff --git a/module/language/value/spec.scm b/module/language/value/spec.scm
index 6c6cff93f..506b07333 100644
--- a/module/language/value/spec.scm
+++ b/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
)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index cd811b3bb..2e875fa4b 100644
--- a/module/oop/goops.scm
+++ b/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
-;;;; 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)
diff --git a/module/oop/goops/active-slot.scm b/module/oop/goops/active-slot.scm
index 79aa1b3f2..4d3bbf72f 100644
--- a/module/oop/goops/active-slot.scm
+++ b/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)
diff --git a/module/oop/goops/composite-slot.scm b/module/oop/goops/composite-slot.scm
index b3f8cc038..bd3eb941e 100644
--- a/module/oop/goops/composite-slot.scm
+++ b/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
-;;;; 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)
diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm
index 86b2d2ce4..52eb29954 100644
--- a/module/oop/goops/describe.scm
+++ b/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
-;;;; 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)
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 05362e077..dda2aea4e 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -128,6 +128,29 @@
(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
diff --git a/module/sxml/simple.scm b/module/sxml/simple.scm
index dcef3b2cb..703ad9137 100644
--- a/module/sxml/simple.scm
+++ b/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."
- (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)))
diff --git a/module/sxml/ssax.scm b/module/sxml/ssax.scm
index a4de0e3e1..f750c934a 100644
--- a/module/sxml/ssax.scm
+++ b/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)
- (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)))
diff --git a/module/sxml/upstream/SSAX.scm b/module/sxml/upstream/SSAX.scm
index 776e3119e..d2b8fd925 100644
--- a/module/sxml/upstream/SSAX.scm
+++ b/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)
- => (lambda (decl-entity)
- (str-handler (cdr decl-entity) "" seed)))
- (else (parser-error port "[wf-entdeclared] broken for " name))))
+ ((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;")) '())))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 81b43b70d..5d927e061 100644
--- a/module/system/base/language.scm
+++ b/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)
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 3f3e7854a..5da7c48f0 100644
--- a/module/system/repl/common.scm
+++ b/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