diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 101 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 63 | ||||
-rw-r--r-- | module/language/assembly/spec.scm | 3 | ||||
-rw-r--r-- | module/language/bytecode/spec.scm | 3 | ||||
-rw-r--r-- | module/language/ecmascript/base.scm | 5 | ||||
-rw-r--r-- | module/language/glil/spec.scm | 6 | ||||
-rw-r--r-- | module/language/objcode/spec.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 13 | ||||
-rw-r--r-- | module/language/tree-il/spec.scm | 3 | ||||
-rw-r--r-- | module/language/value/spec.scm | 3 | ||||
-rw-r--r-- | module/oop/goops.scm | 15 | ||||
-rw-r--r-- | module/oop/goops/active-slot.scm | 19 | ||||
-rw-r--r-- | module/oop/goops/composite-slot.scm | 17 | ||||
-rw-r--r-- | module/oop/goops/describe.scm | 17 | ||||
-rw-r--r-- | module/oop/goops/save.scm | 41 | ||||
-rw-r--r-- | module/sxml/simple.scm | 188 | ||||
-rw-r--r-- | module/sxml/ssax.scm | 21 | ||||
-rw-r--r-- | module/sxml/upstream/SSAX.scm | 31 | ||||
-rw-r--r-- | module/system/base/language.scm | 4 | ||||
-rw-r--r-- | module/system/repl/common.scm | 5 |
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 . "<&ent1;T;>") (ent1 . "&")) `((,(string->symbol "Abc") . ,(unesc-string "<&>%n")) (,(string->symbol "Next") . "12<&T;>34"))) + (test "%tAbc='<&>
'%nNext='12&ent;34' />" + `((*DEFAULT* . ,(lambda (port name) + (case name + ((ent) "<&ent1;T;>") + ((ent1) "&") + (else (error "unrecognized" name)))))) + `((,(string->symbol "Abc") . ,(unesc-string "<&>%n")) + (,(string->symbol "Next") . "12<&T;>34"))) (assert (failed? (test "%tAbc='<&>
'%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&")) '()))) 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 |