blob: dd2b662e6ed67a2052adadc8c69fc77ce059775b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
;;;; This file is part of Gamma.
;;;; Copyright (C) 2010 Sergey Poznyakoff
;;;;
;;;; This program is free software; you can redistribute it and/or modify it
;;;; under the terms of the GNU General Public License as published by the
;;;; Free Software Foundation; either version 3 of the License, or (at your
;;;; option) any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License along
;;;; with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;
(use-modules (gamma expat))
(let ((level 0))
(letrec ((elt-start (lambda (name attrs)
(display (make-string (* 2 level) #\space))
(display name)
(for-each
(lambda (x)
(display " ")
(display (car x))
(display "=")
(display (cdr x)))
attrs)
(newline)
(set! level (1+ level))))
(elt-end (lambda (name)
(set! level (1- level)))))
(catch 'gamma-xml-error
(lambda ()
(xml-parse (xml-make-parser
#:start-element-handler elt-start
#:end-element-handler elt-end)))
(lambda (key func fmt args ctx)
(with-output-to-port
(current-error-port)
(lambda ()
(cond
((not ctx)
(apply format #t fmt args)
(newline))
(else
(format #t
"~A:~A: ~A~%"
(xml-error-descr ctx #:line)
(xml-error-descr ctx #:column)
(xml-error-string (xml-error-descr ctx #:error-code)))
(if (xml-error-descr ctx #:has-context?)
(let ((ctx-text (xml-error-descr ctx #:context))
(ctx-pos (xml-error-descr ctx #:error-offset)))
(format #t
"Context (^ marks the point): ~A^~A~%"
(substring ctx-text 0 ctx-pos)
(substring ctx-text ctx-pos))))
(exit 1)))))))))
|
