Better error messages, plus fix for the tag syntax
original commit: 93d8e89b66a3e1f659a6c4e59a6d8086debe0d0a
This commit is contained in:
parent
ec73f42c1b
commit
757b462154
|
@ -9,6 +9,10 @@
|
||||||
(define STRING-DB (make-hash))
|
(define STRING-DB (make-hash))
|
||||||
(define ENTRY-DB (make-hash))
|
(define ENTRY-DB (make-hash))
|
||||||
|
|
||||||
|
(define (perror ip sym fmt . args)
|
||||||
|
(define loc (call-with-values (λ () (port-next-location ip)) list))
|
||||||
|
(apply error sym (string-append fmt " @ line ~a column ~a byte ~a") (append args loc)))
|
||||||
|
|
||||||
(define (read-while pred ip)
|
(define (read-while pred ip)
|
||||||
(list->string
|
(list->string
|
||||||
(let loop ()
|
(let loop ()
|
||||||
|
@ -37,13 +41,17 @@
|
||||||
[(? eof-object?)
|
[(? eof-object?)
|
||||||
(void)]
|
(void)]
|
||||||
[c
|
[c
|
||||||
(error 'read-entries "Expected % or @, got ~v" c)]))
|
(perror ip 'read-entries "Expected % or @, got ~v" c)]))
|
||||||
|
|
||||||
(define (read-entry ip)
|
(define (read-entry ip)
|
||||||
(match (read-until (λ (c) (char=? c #\{)) ip)
|
(match (read-until (λ (c) (char=? c #\{)) ip)
|
||||||
[(app string-downcase "string")
|
[(app string-downcase "string")
|
||||||
(slurp-whitespace ip)
|
(slurp-whitespace ip)
|
||||||
(read-char ip)
|
(match (read-char ip)
|
||||||
|
[#\{
|
||||||
|
(void)]
|
||||||
|
[c
|
||||||
|
(perror ip 'read-entry "Parsing entry, expected {, got ~v" c)])
|
||||||
(define tag (read-tag ip))
|
(define tag (read-tag ip))
|
||||||
(slurp-whitespace ip)
|
(slurp-whitespace ip)
|
||||||
(match (read-char ip)
|
(match (read-char ip)
|
||||||
|
@ -55,9 +63,9 @@
|
||||||
[#\}
|
[#\}
|
||||||
(hash-set! STRING-DB tag string)]
|
(hash-set! STRING-DB tag string)]
|
||||||
[c
|
[c
|
||||||
(error 'read-entry "Parsing string, expected }, got ~v" c)])]
|
(perror ip 'read-entry "Parsing string, expected }, got ~v; tag is ~v; string is ~v" c tag string)])]
|
||||||
[c
|
[c
|
||||||
(error 'read-entry "Parsing string, expected =, got ~v" c)])]
|
(perror ip 'read-entry "Parsing string, expected =, got ~v; tag is ~v" c tag)])]
|
||||||
[(app string-downcase "comment")
|
[(app string-downcase "comment")
|
||||||
(read-char ip)
|
(read-char ip)
|
||||||
(let loop ()
|
(let loop ()
|
||||||
|
@ -87,15 +95,19 @@
|
||||||
[#\}
|
[#\}
|
||||||
(hash atag aval)]
|
(hash atag aval)]
|
||||||
[c
|
[c
|
||||||
(error 'read-entry "Parsing entry, expected , or }, got ~v" c)])]
|
(perror ip 'read-entry "Parsing entry, expected , or }, got ~v; label is ~v; atag is ~v; aval is ~v" c label atag aval)])]
|
||||||
[c
|
[c
|
||||||
(error 'read-entry "Parsing entry, expected =, got ~v" c)])))
|
(perror ip 'read-entry "Parsing entry tag, expected =, got ~v; label is ~v; atag is ~v" c label atag)])))
|
||||||
(hash-set! ENTRY-DB label
|
(hash-set! ENTRY-DB label
|
||||||
(hash-set alist 'type typ))]))
|
(hash-set alist 'type typ))]))
|
||||||
|
|
||||||
(define (read-tag ip)
|
(define (read-tag ip)
|
||||||
(slurp-whitespace ip)
|
(slurp-whitespace ip)
|
||||||
(string-downcase (read-until char-whitespace? ip)))
|
(string-downcase
|
||||||
|
(read-until
|
||||||
|
(λ (c) (or (char-whitespace? c)
|
||||||
|
(char=? c #\=)))
|
||||||
|
ip)))
|
||||||
|
|
||||||
(define (read-value ip)
|
(define (read-value ip)
|
||||||
(slurp-whitespace ip)
|
(slurp-whitespace ip)
|
||||||
|
@ -118,7 +130,7 @@
|
||||||
(hash-ref STRING-DB string-tag
|
(hash-ref STRING-DB string-tag
|
||||||
(λ () string-tag))]
|
(λ () string-tag))]
|
||||||
[c
|
[c
|
||||||
(error 'read-value "Parsing value, expected {, got ~v" c)]))
|
(perror ip 'read-value "Parsing value, expected {, got ~v" c)]))
|
||||||
|
|
||||||
(read-entries ip)
|
(read-entries ip)
|
||||||
|
|
||||||
|
@ -129,6 +141,7 @@
|
||||||
(with-input-from-file
|
(with-input-from-file
|
||||||
pth
|
pth
|
||||||
(λ ()
|
(λ ()
|
||||||
|
(port-count-lines! (current-input-port))
|
||||||
(bibtex-parse (current-input-port)))))
|
(bibtex-parse (current-input-port)))))
|
||||||
bibdb)
|
bibdb)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user