;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2024 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

(module "s7unit.scm")

;; Note: We load the bst module with module/expose, because this suite
;; tests the internal functions of the 'bst module.
;; It would be possible to make these tests using only the exposed
;; interface, but they would be more complicated by being indirect.
(module/expose 'bst)
(module 'bibtex)                        ;for bib-string-table

(print-warning 'push #f)
(set! (*s7* 'stacktrace-defaults) '(6 45 80 45 #f))

;; convenience: (call/lookup 'chr.to.int$ '("1"))
;; looks up the function 'chr.to.int$, and calls it on the given stack
(define (call/lookup context btx-func arg-stack)
  (cond ((bst-function/bstname context btx-func)
         => (λ (f)
              (f context arg-stack '((call/lookup . #f)))))
        (else ; we can't call assert-fail here, because we're not within a test-suite
         (eprintf "call/lookup: no function ~s~%" btx-func)
         ;;#f will presumably result in a failure in the caller
         #f)))

(test-suite
 "make stack functions"
 (let ()
   ;; implementation detail: (bst-wrap-function/stack foo ...) defines a function btx$foo
   (bst-wrap-function/stack -/stack (λ (entry n1 n2) (- n1 n2)) number? number?)
   (bst-wrap-function/stack dup (lambda (entry x) (list x "second")) #f)
   (bst-wrap-function/stack gobble (lambda (entry x) '()) #f)

   ;; call with 'entry' #f (ignored)
   (assert-equal (btx$-/stack #f '(1 3 6) '())
                 '(2 6))
   (assert-exception (btx$-/stack #f '(1) '())) ;too few arguments
   (assert-exception (btx$-/stack #f '(1 "string") '())) ;wrong type of argument

   ;; returning a list of objects to the stack
   (assert-equal (btx$dup #f '(1 "foo") '())
                 '("second" 1 "foo"))

   ;; returning no objects
   (assert-equal (btx$gobble #f '(1 2 3) '())
                 '(2 3))))

;; Make a test context, initialised with a suitable set of testable
;; global variables.
;; If there is an argument, then it is a single-entry BibTeX string,
;; which we parse and add as a *entry* to the context, just as the
;; ITERATE macro does in RUN-BST-PROGRAM.
(define (make-test-context . db/str)
  (let ((entries (map cdr
                      (and (not (null? db/str))
                           (parse-bibtex-string (car db/str)))))
        (context (make-context)))
    (varlet (curlet) context)
    (for-each (lambda (p)
                (local-variable-set-type! (car p) (cdr p)))
              `((fi . readonly)         ;will be given integer values
                (fs . readonly)         ;...strings
                (fy . readonly)         ;...symbols/macros (eg 'jan')
                (fx . readonly)         ;field will remain undefined
                (li . ,integer?)
                (ls . ,ustring?)
                (lx . ,ustring?)))    ;local variable will remain unset
    (global-variable-set-type! 'gi integer?)
    (global-variable-set-type! 'gs ustring?)
    (if (null? entries)
        context
        (inlet context '*entry* (car entries)))))

;; s->u turns strings into ustrings
;; We use it in btx-test-suite simply in order to make the input visually tidier
(define (s->u x)
  (cond ((integer? x) x)
        ((ustring? x) x)
        ((string? x) (make-ustring x))
        (else (beastie-error "Unexpected test input in s->u: ~s" x))))
;; testbtx and testbtx/here are the same here, but only the former are
;; also checked in the generated .bst file (see
;; extract-bst-tests.scm).  They're excluded because I can't work out
;; how to check 'actual' when the result is more than one thing.
(define-macro (btx-test-suite label entry/str . body)
  `(let ((context (make-test-context ,entry/str)))
     (let* ((testbtx (macro (label func input expected)
                       `(assert-equal (,(bst-function/bstname context func)
                                       context (quote ,input) '())
                                      (quasiquote ,expected))))
            (testbtx/here testbtx))
       (test-suite ,label . ,body))))

(btx-test-suite
 "btx functions"
 "@article{citation1, fi={1}, fs={value2}}"
 ;; The results of these can be compared with BibTeX by running a script
 ;; generated from the output of extract-bst-tests.scm run on
 ;; test-btxhak.scm (see the Makefile, target "bibtex-comparison")
 ;;
 ;; All of these are expected to match the BibTeX behaviour.
 ;;
 ;; Note that, because in the usual .bst layout the top of the stack
 ;; is to the right (ie, the first popped value is the rightmost, but
 ;; here the top of the stack is at the left of the list, all of the
 ;; arguments here appear to be the wrong way around
   (testbtx #">1"	> (10 100) (1))
   (testbtx #">2"	> (100 10) (0))
   (testbtx #"<1"	< (10 100) (0))
   (testbtx #"<2"	< (100 10) (1))

   (testbtx #"=1"	= (1 1) (1))
   (testbtx #"=2"	= (1 0) (0))
   (testbtx #"=3"	= (#"a" #"a") (1))
   (testbtx #"=4"	= (#"a" #"b") (0))

   (testbtx #"+1"	+ (1 2) (3))
   (testbtx #"-1"	- (1 2) (1))
   (testbtx #"-2"	- (2 1) (-1))

   (testbtx #"*1"	* (#"b" #"a") (#"ab"))

   (testbtx #"dot1"	add.period$ (#"a") (#"a."))
   (testbtx #"dot2"	add.period$ (#"a.") (#"a."))
   (testbtx #"dot3"	add.period$ (#"a?") (#"a?"))
   (testbtx #"dot4"	add.period$ (#"a!") (#"a!"))
   (testbtx #"dot5"	add.period$ (#"a:") (#"a:."))

   (testbtx #"case0"	change.case$ (#"l" #"oNe: TWO: three") (#"one: two: three"))
   (testbtx #"case1"	change.case$ (#"U" #"oNe: TWO: three") (#"ONE: TWO: THREE"))
   ;; here, note that the 'o' of "one" and 't' of "three" are left
   ;; alone, rather than being uppercased
   (testbtx #"case2"	change.case$ (#"t" #"oNe: TWO: three") (#"one: Two: three"))
   (testbtx #"case3"	change.case$ (#"t" #"ONE: TWO: THREE") (#"One: Two: Three"))
   ;; a character immediately following a colon
   ;; (ie, not a ‘colon and then nonnull white space‘)
   ;; isn't excepted from the lowercasing
   (testbtx #"case4"	change.case$ (#"t" #"O:ABC:abc") (#"O:abc:abc"))

   ;; now with braces
   (testbtx #"case5"	change.case$ (#"t" #"{ONE}: {two}: {THREE}")
  	    (#"{ONE}: {two}: {THREE}"))
   (testbtx #"case6"	change.case$ (#"u" #"{ONE}: {two}: {THREE}")
  	    (#"{ONE}: {two}: {THREE}"))
   (testbtx #"case7"	change.case$ (#"l" #"{ONE}: {two}: {THREE}")
  	    (#"{ONE}: {two}: {THREE}"))
   ;; the following should be accompanied by warning messages,
   ;; both in beastie and in the BibTeX log file
   (testbtx #"case8"	change.case$ (#"one" 1) (#""))
   (testbtx #"case9"	change.case$ (1 #"one") (#""))
   (testbtx #"case10"	change.case$ (#"X" #"one") (#"one"))

   (testbtx #"conv0"	chr.to.int$ (#"@") (64))
   (testbtx #"conv1"	int.to.chr$ (64) (#"@"))
   (testbtx #"conv2"	int.to.str$ (64) (#"64"))
   (assert-exception (call/lookup context 'chr.to.int$ '(#"ab")))

   (testbtx/here #"misc0"	duplicate$ (#"a" 1) (#"a" #"a" 1))
   (testbtx/here #"misc1"	duplicate$ (1 #"a") (1 1 #"a"))
   (testbtx/here #"misc2"	pop$ (1 2 3) (2 3))
   (testbtx/here #"misc3"	quote$ () (,(make-ustring "\"")))
   (testbtx/here #"misc4"	skip$ (1 2 3) (1 2 3))
   (testbtx/here #"misc5"	swap$ (1 2 3) (2 1 3))
   ;; The next ones produce output on stderr.
   ;; I'm not currently sure how to test these.
   ;; (testbtx #"stack1"	top$ (#"stacktop" 2 3) (2 3))
   ;; (testbtx #"stack2"	stack$ (1 2 3) ())
   ;; (testbtx #"stack3"	show.stack$$ (1 2 #"a") (1 2 #"a"))
   ;; (testbtx #"stack4"	warning$ (#"boo!" 2 3) (2 3))

   ;; "123456789" start len substring$, with 1-based indexing
   (testbtx #"sub0"	substring$ (5 1 #"123456789")	(#"12345"))
   (testbtx #"sub1"	substring$ (5 3 #"123456789")	(#"34567"))
   (testbtx #"sub2"	substring$ (7 3 #"123456789")	(#"3456789"))
   (testbtx #"sub3"	substring$ (1 9 #"123456789")	(#"9"))
   (testbtx #"sub4"	substring$ (99 3 #"123456789")	(#"3456789"))
   (testbtx #"sub5"	substring$ (4 -3 #"123456789")	(#"4567"))
   (testbtx #"sub6"	substring$ (7 -3 #"123456789")	(#"1234567"))
   (testbtx #"sub7"	substring$ (99 -3 #"123456789")	(#"1234567"))
   (testbtx #"sub8"	substring$ (1 -9 #"123456789")	(#"1"))
   (testbtx #"sub9"	substring$ (99 -9 #"123456789")	(#"1"))
   ;; the following aren't out-of-range errors
   (testbtx #"sub10"	substring$ (1 10 #"123456789")	(#""))
   (testbtx #"sub11"	substring$ (1 -10 #"123456789")	(#""))
   (assert-exception            ;zero start index
    (call/lookup context 'substring$ '(5 0 #"123")))
   ;; In the following case, we are giving the wrong type of arguments to substring$.
   ;; BibTeX produces a warning, but not an error, and leaves "" on the stack
   ;; (see btxhak Sect.5.3;
   ;; I think it appears in one of the standard style files).
   ;; We don't check the warning, but we check we don't throw
   ;; an error, and that the "" is indeed left behind.
   ;; No: I'm not going to do this unless I need to.
   ;; See discussion in bst.scm:get-from-stack*
   ;;(testbtx #"sub12"	substring$ (#"1" #"1" #"123456789") (#""))

   (testbtx #"pfx0"	text.prefix$ (3 #"12345") (#"123"))
   (testbtx #"pfx1" 	text.prefix$ (99 #"12345") (#"12345"))
   (testbtx #"tlen0"	text.length$ (#"12345") (5))

   ;; testbtx/here because BibTeX objects to the use of the type$
   ;; function in the context where this test runs
   (testbtx/here #"type"	type$ () (#"article"))

   ;; this is a bogus value -- I don't know what it should be
   ;; (or, rather, I don't really know why it is what BibTeX makes it)
   (testbtx/here #"width"	width$ (#"hello") (500))

   ;; The following are not beastie tests, because we don't implement
   ;; n.dashify directly.  The goal is instead to confirm what plain.bst's
   ;; n.dashify function actually does.  Thus they should be uncommented,
   ;; and the test run, using the "bibtex-comparison" target, if there is any doubt.
   ;; (testbtx #"ndashify0"	n.dashify (#"1-2") (#"1--2"))
   ;; (testbtx #"ndashify1"	n.dashify (#"3--4") (#"3--4"))
   ;; (testbtx #"ndashify2"	n.dashify (#"5+") (#"5+"))
   ;; (testbtx #"ndashify3"	n.dashify (#"6-7-8") (#"6--7--8"))
   )

(test-suite
 "stack running"
 ;; The following tests are very much not part of an exposed interface.
 ;; They exist in order to help check that the lower-level functions
 ;; which implement the .bst support are working.
 ;; They are actually tests of the functions defined within MAKE-CONTEXT.
 (bib-string-table '*reset-for-tests*)
 (bib-string-table-set! #"dec" #"December")
 (let ((context
        (make-test-context
         "@article{citation1,fi={1},fs={value3},fy=dec,fy2=jan#dec#\"x\"}")))
   (varlet (curlet) context)            ;bring the context functions into this let

   ;; we can't set things before they're declared
   ;; (this returns #f rather than throwing an exception,
   ;; as an implementation detail)
   ;; (assert-false (global-variable-set! 'dec "December"))
   ;; (assert-equal (global-variable-get 'dec) #f)
   ;; (global-variable-set-type! 'dec string?)
   ;; (assert-true (global-variable-set! 'dec "December"))
   ;; (assert-equal (global-variable-get 'dec) "December")

   (assert-equal (global-variable-get 'gs) #"")
   (assert-equal (global-variable-get 'gi) 0)
   ;; set global variables
   (global-variable-set! 'gi 1)
   (global-variable-set! 'gs #"one")
   (assert-exception (global-variable-set! 'gi #"string"))
   (assert-exception (global-variable-set! 'gs 1))
   (assert-equal (global-variable-set! 'unknown 1) #f) ;...rather than failing
   (assert-equal (global-variable-get 'gi) 1)
   (assert-equal (global-variable-get 'gs) #"one")

   ;; retrieving the dummy local value 'cite$ gets the citation key as a symbol
   (assert-equal (bst-variable-get/local context 'entry-cite$) 'citation1)
   (assert-equal (bst-variable-get/local context 'entry-type$) 'article)
   ;; we can't set entry fields
   (assert-exception (bst-variable-set/local! context 'fi "nothing"))
   ;; and we can't set declared fields with the wrong type
   (assert-exception (bst-variable-set/local! context 'li "nothing")) ;wrong type

   (bst-variable-set/local! context 'li 1)
   ;; FIXME: should this be string or ustring -- can't make up my mind
   (bst-variable-set/local! context 'ls #"ls-")
   ;; Don't set lx.

   ;; we can't set entry fields
   (assert-exception (bst-variable-set/local! context 'fs #"x"))
   ;; we can't set global fields which shadow entry-local fields or variables
   (assert-exception (global-variable-set-type! 'li integer?))

   (assert-equal (bst-variable-get/local context 'fi) #"1")
   (assert-equal (bst-variable-get/local context 'fs) #"value3")
   (assert-equal (bst-variable-get/local context 'fy) #"December") ;'dec -> "December"
   (assert-equal (bst-variable-get/local context 'fy2) #"janDecemberx")
   (assert-equal (bst-variable-get/local context 'li) 1) ;not coerced to string
   (assert-equal (bst-variable-get/local context 'ls) #"ls-")
   ;; declared but unset
   (assert-equal (bst-variable-get/local context 'lx) #<undefined>)

   ;; we're NOT able to set undeclared fields...
   (assert-equal (bst-variable-set/local! context 'unknown 1) #f)

   ;; and keys must be symbols
   (assert-exception (bst-variable-set/local! context "string key" 1))
   (assert-exception (bst-variable-set/local! context #"string key" 1))

   ;; undeclared and unknown keys return #f
   (assert-false (bst-variable-get/local context 'unknown1))
   (assert-false (global-variable-get 'unknown2))

   ;; now the same, but using :=
   (let ((b (btx-make-block* '(1 'li := li
                                 #"x" 'ls := ls
                                 2 'gi := gi
                                 #"y" 'gs := gs))))
     (assert-equal ((block-func b) context '() '()) '(#"y" 2 #"x" 1)))

   ;; Btxhak Sect.5.3 built-in fields and variables.
   ;; The following two numbers should be... big
   (assert-true (> (global-variable-get 'entry.max$) 99))
   (assert-true (> (global-variable-get 'global.max$) 99))
   ;; undefined, but not an error to retrieve
   (assert-equal (bst-variable-get/local context 'sort.key$) #<undefined>)
   ;; settable
   (assert-true (bst-variable-set/local! context 'sort.key$ #"SORT"))
   ;; ...successfully
   (assert-equal (bst-variable-get/local context 'sort.key$) #"SORT")

   (let ((b (btx-make-block* '(1 2 +))))
     (assert-equal ((block-func b) context '() '()) '(3)))

   (let ((b (btx-make-block* `(#"ls-" 'ls :=
                               #"1" fi = ;test is true
                               ,(btx-make-block* '(ls fs *))
                               'skip$
                               if$))))
     (assert-equal ((block-func b) context '() '()) '(#"ls-value3")))
   (let ((b (btx-make-block* `(#"ls-" 'ls :=
                               #"0" fi = ;test is false
                               ,(btx-make-block* '(ls fs *))
                               'skip$
                               if$))))
     (assert-equal ((block-func b) context '() '()) '()))

   ;; while loop
   ;;
   ;; Compare the .bst program
   ;;
   ;;     "" 'ls :=
   ;;     #5
   ;;     { #1 - duplicate$ #0 > }
   ;;     { duplicate$ top$
   ;;       ls "+" * 'ls := }
   ;;     while$
   ;;     top$ %pop$ % duplicate$ top$
   ;;     "Plusses: " ls * write$ newline$
   ;;
   ;;     "next" top$
   ;;     "" 'ls :=
   ;;     #5 'li :=
   ;;     { li #1 - 'li :=
   ;;       li #0 > }
   ;;     { ls "0" * 'ls := }
   ;;     while$
   ;;     "Result: " ls * write$ newline$
   ;;
   ;; which prints 4, 3, 2, 1 to the log file, and writes "Plusses: ++++"
   ;; and "Result: 0000" to the .bbl.
   ;; Note that the test is always executed at least once.
   (let ((b (btx-make-block* `(#"" 'ls :=
                               5
                               ,(btx-make-block* '(1 - duplicate$ 0 >))
                               ,(btx-make-block* '(ls #"+" * 'ls :=))
                               while$))))
     (assert-equal ((block-func b) context '() '()) '(0))
     (assert-equal (bst-variable-get/local context 'ls) #"++++"))

   (let ((b (btx-make-block* `(#"" 'ls :=
                               5 'li :=
                               ,(btx-make-block* '(li 1 -
                                                      'li :=
                                                      li 0 >))
                               ,(btx-make-block* '(ls #"0" * 'ls :=))
                               while$))))
     (assert-equal ((block-func b) context '() '()) '())
     (assert-equal (bst-variable-get/local context 'ls) #"0000"))

   ;; a while block with skip$ as the body
   (let ((b (btx-make-block* `(5 'li :=
                                 ,(btx-make-block* '(li 1 -
                                                        'li :=
                                                        li 0 >))
                                 (quote skip$)
                                 while$))))
     (assert-equal (bst-variable-get/local context 'li) 0))
   ;; and with a function as the test
   (function-set! 'decrement-li
                             (lambda (e s call-stack)
                               ;; decrement li and leave it on the stack
                               (let ((li (- (bst-variable-get/local e 'li) 1)))
                                 (bst-variable-set/local! e 'li li)
                                 (cons li s))))
   (let ((b (btx-make-block* `(#"" 'ls :=
                               5 'li :=
                               'decrement-li
                               ,(btx-make-block* '(ls #"0" * 'ls :=))
                               while$))))
     (assert-equal ((block-func b) context '() '()) '())
     (assert-equal (bst-variable-get/local context 'ls) #"0000"))

   ;; The following would benefit from being checked with testbtx, but
   ;; it's fiddly to set that up.
   (assert-equal 'lookup-cite (call/lookup context 'cite$ '()) '(#"citation1"))

   (bst-variable-set/local! context 'li 1)
   (bst-variable-set/local! context 'ls #"x")
   (for-each (lambda (p)
               (let ((b (btx-make-block* (car p))))
                 (assert-equal ((block-func b) context '() '()) (cdr p))))
             '(((lx empty$) . (1))
               ((li empty$) . (0))
               ((ls empty$) . (0))
               ((#"" empty$) . (1))
               ((#"  	  " empty$) . (1)) ;includes tab
               ((#" x " empty$) . (0))
               ((fs empty$) . (0))
               ((fi empty$) . (0))
               ((fx empty$) . (1))

               ((lx missing$) . (1))
               ((fi missing$) . (0))
               ((fs missing$) . (0))
               ((fx missing$) . (1))
               ((cite$ missing$) . (0))))
   (assert-exception ;'empty-unknown
                     (let ((b (btx-make-block* '(unknown empty$))))
                       ((block-func b) context '() '()))))

 ;; Looking at crossrefs: the crossref variable should be defined
 ;; whether or not there is a crossref field in the .bib database.
 (let ((context
        (make-test-context
         "@article{citation1,fi={1},fs={value3},fy=dec,crossref={citation2}}")))
   (assert-equal (bst-variable-get/local context 'crossref) #"citation2"))
 (let ((context
        (make-test-context
         "@article{citation1,fi={1},fs={value3},fy=dec}")))
   ;; Btxhak Sect.5.3 notes that field 'crossref' is built-in, so that
   ;; it should evaluate to undefined, here, so that `crossref missing$` will
   ;; evaluate to true, and not fail.
   (assert-equal (bst-variable-get/local context 'crossref) #<undefined>))

 ;; call.type$
 ;;
 ;; Note: we here define the 'article and 'default.type functions, globally
 (let ((context
        (make-test-context
         "@article{article-key, f1={1}, fs={article-value}}")))
   (varlet (curlet) context)
   (function-set! 'article
                  (λ (e s call-stack)
                    (printf "article: key=~s"
                            (bst-variable-get/local context 'entry-cite$))
                    s))
   (assert-equal (with-output-to-string
                   (λ ()
                     (call/lookup context 'call.type$ '())))
                 "article: key=article-key")

   ;; run a block which contains a defined function
   (function-set! 'inc (btx-make-block* '(1 +) 0))
   (let ((b (btx-make-block* '(1 'li := li inc))))
     (assert-equal ((block-func b) context '() '()) '(2))))

 (let ((context
        (make-test-context
         "@book{book-key, fi={99}, fs={book-value}}")))
   (varlet (curlet) context)
   (assert-exception (call/lookup context 'call.type$ '()))

   (function-set! 'default.type
                             (λ (ctx s call-stack)
                               (format #t "default.type: type=~s key=~s"
                                       (bst-variable-get/local ctx 'entry-type$)
                                       (bst-variable-get/local ctx 'entry-cite$))
                               s))
   (assert-equal (with-output-to-string
                   (lambda ()
                     (call/lookup context 'call.type$ '())))
                 "default.type: type=book key=book-key")))

(test-suite
 "Names and formatting"
 (let ((context (make-context)))
   (module/expose 'authors)
   (let ((nn (bst-function/bstname context 'num.names$)))
     (assert-equal (nn #f '(#"First Last") '()) '(1))
     (assert-equal (nn #f '(#"First Last and Smith, Jr, John and others") '()) '(3))
     ;; the following should produce a warning and a result of 0
     (let ((nw (print-warning 'get-count)))
       (assert-equal (nn #f '(#"") '()) '(0))
       (assert-equal (- (print-warning 'get-count) nw) 1)))

   (let ((fn (λ (st)
               ;;call format.name$ with dummy entry and empty call-stack
               (call/lookup context 'format.name$ st)))
         (fmt #"{vv~}{ll}{, jj}{, f}?")
         (charlie-fish #"Charles Louis Xavier Joseph de la Vall{\\'e}e Poussin")
         (last-smith #"First Last and Smith, Jr, John and others"))
     (assert-equal (fn `(,fmt 1 ,charlie-fish))
                   ;; btxhak wants '("de~la Vall{\\'e}e~Poussin, C.~L. X.~J?")
                   ;; bibtex 0.99d produces: "de~la Vall{\’e}e~Poussin, C. L. X.~J?"
                   ;; we're content with...
                   '(#"de~la Vallée Poussin, C.~L. X.~J?"))
     (assert-equal (fn `(,fmt 1 ,last-smith))
                   '(#"Last, F?"))
     (assert-equal (fn `(,fmt 2 ,last-smith))
                   '(#"Smith, Jr, J?"))
     (assert-equal (fn `(,fmt 3 ,last-smith))
                   '(#"et al."))
     ;; when the index is out of range, we get the first name
     (assert-equal (fn `(,fmt 4 ,last-smith))
                   '(#"Last, F?")))
   ;; there are other tests of parsing btx specs, and formatting, in test-authorlist.scm
   ))

(test-suite
 "Misc functions"
 (let ((context
        (make-test-context
         "@article{citation1, fi={1}, fs={value5}}")))
   (clear-preamble*!)

   (let ((b (btx-make-block* '(preamble$))))
     (assert-equal ((block-func b) context '() '()) '(#""))
     (append-preamble! #"preamble string")
     (assert-equal ((block-func b) context '() '()) '(#"preamble string")))

   (let ((b (btx-make-block* '(#"ab=+-_1~\"" purify$)))) ;" (quote-matching)
     (assert-equal ((block-func b) context '() '()) '(#"ab  - 1~ ")))
   ;; (let ((b (btx-make-block* '(123 purify$))))
   ;;   (assert-equal ((block-func b) context '() '()) '("123")))

   (assert-equal (call/lookup context ':= '(li 5)) '())
   (assert-equal (bst-variable-get/local context 'li) 5)

   (define (authorlist->list/debug al)
     (map (lambda (a)
            (cond ((eqv? a 'others) 'others)
                  (else (author->list a))))
          al))
   (assert-equal (authorlist->list/debug
                  (string->authorlist "First Last and Smith, Jr, John and others"))
                 '((("First") #f ("Last") #f)
                   (("John") #f ("Smith") ("Jr"))
                   others))))

(test-suite
 "printf$$"
 ;; A suitable test/demo file is:
 ;;
 ;; function {try.printing}
 ;; {
 ;;   "Hello from try.printing" write$ newline$
 ;;   "test.txt" printf.push$$
 ;;   "Going to a file" write$ newline$
 ;;   #1 #2 "string" "string" "sending 1=~s and 2=~s and string=~a/~s via printf~%" printf$$
 ;;   printf.pop$$
 ;;   "file was: " swap$ * write$ newline$
 ;;
 ;;   #0 printf.push$$              %write to a string
 ;;   "Going to a file" write$ newline$
 ;;   #1 #2 "string" "string" "sending 1=~s and 2=~s and string=~a/~s via printf~%" printf$$
 ;;
 ;;   #1 printf.push$$              %write to stdout
 ;;   "Hello on stdout" write$ newline$
 ;;
 ;;   #2 printf.push$$              %write to stderr
 ;;   "boo on stderr" write$ newline$
 ;;   printf.pop$$
 ;;
 ;;   "hello on stdout via printf~%" printf$$
 ;;   printf.pop$$
 ;;
 ;;   "More to a file" write$
 ;;   printf.pop$$
 ;;   "string was: " swap$ * write$ newline$
 ;; }
 ;;
 ;; execute{try.printing}
 (let ((context
        (make-test-context
         "@article{citation2, fi={2}}")))

   (let ((b (btx-make-block* '(#"tmp-printf-output.txt" printf.push$$
                               #"write" write$ newline$
                               1 2 #"string" #"string"
                               ;; use all of the format specifiers
                               #"sending 1=~s and 2=~a and string=~A/~S via~~printf~%"
                               printf$$
                               printf.pop$$))))
     (assert-equal ((block-func b) context '() '())
                   '(#"tmp-printf-output.txt"))
     (let ((lines (file->list-of-lines "tmp-printf-output.txt")))
       (assert-equal lines
                     '("write"
                       "sending 1=1 and 2=2 and string=string/\"string\" via~printf"))))

   (let ((b (btx-make-block* '(0 printf.push$$
                                 ;; similar to above
                                 #"write" write$
                                 1 #"1=~s~%" printf$$
                                 printf.pop$$))))
     (assert-equal ((block-func b) context '() '())
                   '(#"write1=1\n")))

   ;; write to current-output/error-port
   (let ((b (btx-make-block* '(1 printf.push$$ #"boo" write$ printf.pop$$))))
     (assert-equal
      (call-with-output-string
       (λ (string-port)
         (let-temporarily (((current-output-port) string-port))
           ;; ...having redirected the port to this string
           (assert-equal ((block-func b) context '() '())
                         '(#"*stdout*"))) ;I'm not committed to the content of this string
         (get-output-string string-port)))
      "boo"))

   (let ((b (btx-make-block* '(2 printf.push$$ #"boo" write$ printf.pop$$))))
     (assert-equal
      (call-with-output-string
       (λ (string-port)
         (let-temporarily (((current-error-port) string-port))
           (assert-equal ((block-func b) context '() '())
                         '(#"*stderr*")))
         (get-output-string string-port)))
      "boo"))

   (let ((nw (print-warning 'get-count)))
     ;; errors...
     (assert-exception (btx+printf context '() '())) ;empty stack
     (assert-exception (btx+printf context '(1) '())) ;wrong type of format

     ;; ... and warnings
     (assert-equal (btx+printf context '(#"fmt~x" 1) '()) '(1)) ;bad format
     (assert-equal (btx+printf context '(#"fmt~") '()) '()) ;trailing tilde

     ;; with an empty stack...
     (assert-equal (btx+printf-pop context) ; should produce a warning, but nothing more
                   '())                     ; ...and leave nothing on the stack

     ;; ... adds up to three
     (assert-equal (- (print-warning 'get-count) nw) 3))))

(test-suite
 "Parsing .bst"

 (define (blank-line-numbers l)
   (cond ((null? l) '())
         ((list? (car l))
          (cons (blank-line-numbers (car l))
                (blank-line-numbers (cdr l))))
         ((eqv? (car l) line-number:)
          `(line-number: X . ,(cddr l)))
         (else (cons (car l) (blank-line-numbers (cdr l))))))

 ;; (assert-equal (parse-bst-string "% comment\n%% more\n")
 ;;               '((comment "% comment")
 ;;                 (comment "%% more")))

 ;; FIXME: we want to permit comments between the items of the ENTRY command,
 ;; but that's tricky in grammar terms.
 ;; Note: I tolerate some off-by-oneness in the line numbers here,
 ;; arising from the internals of the lexing.
 (assert-equal (parse-bst-string "EnTRY { author TITLE }{}  \n   {   laBel  }\n  strings { s t} INTEGERS {namePTR}\nFunction{TesT}\n{'S :=}")
               '((entry (author title) () (label))
                 (strings (s t))
                 (integers (nameptr))
                 (function test (block ('s :=) line-number: 5) line-number: 4)))
 (assert-equal (blank-line-numbers
                (parse-bst-string "function{not} { { #0 } {#1} if$ }"))
               '((function not
                           (block ((block (0) line-number: X)
                                   (block (1) line-number: X)
                                   if$) line-number: X)
                           line-number: X)))
 ;; comments in unexpected places
 (assert-equal (parse-bst-string "EnTRY { author title }%comment1\n{}  %comment2\n       %comment3\n   {   label  }")
               '((entry (author title) () (label))))
 (assert-equal (parse-bst-string "macro{foo} % comment\n{\"content\"}")
               `((macro foo #"content")))
 (assert-equal (blank-line-numbers
                (parse-bst-string "% before\nfunction{foo} % within\n{#1 %end\n}"))
               `((function foo (block (1) line-number: X) line-number: X)))
 (assert-equal (blank-line-numbers
                (parse-bst-string "% before\nEXECUTE {% within\nfuncname}"))
               `((execute funcname line-number: X)))

;; note that this isn't good .bst: if it were, the 'skip$ would be {""}
 (assert-equal (blank-line-numbers
                (parse-bst-string "FUNCTION {format.date}\n{ month empty$\n    'skip$\n    { month \" \" * }\n  if$\n  year empty$\n    { \"9999\" }\n    { year }\n  if$\n  *\n}"))
               '((function format.date
                           (block
                            (month empty$
                                   'skip$
                                   (block (month #" " *) line-number: X)
                                   if$
                                   year empty$
                                   (block (#"9999") line-number: X)
                                   (block (year) line-number: X)
                                   if$
                                   *)
                            line-number: X)
                           line-number: X)))

 (assert-equal (blank-line-numbers
                (parse-bst-string "macro { jan } {\"January\"} READ iterate{call.type$} SORT"))
               '((macro jan #"January")
                 (read)
                 (iterate call.type$ line-number: X)
                 (sort line-number: X)))

 ;; unparsing with write/bstscm!
 (let ((progs '((entry (author title journal publisher year month) () (label))
                (function format.names
                          ('s := 1 'nameptr :=
                              s num.names$ 'numnames :=
                              numnames 'namesleft :=
                              (namesleft 0 >)
                              (s nameptr "{ff~}{vv~}{ll}{, jj}" format.name$ 't :=
                                 nameptr 1 >
                                 (namesleft 1 >
                                    (", " * t *)
                                    (numnames 2 >
                                      ("," *)
                                      'skip$
                                    if$
                                    t "others" =
                                      (" et~al." *)
                                      (" and " * t *)
                                    if$)
                                  if$)
                                 't
                               if$
                               nameptr 1 + 'nameptr :=
                               namesleft 1 - 'namesleft :=)
                              while$)
                          line-number: 48))))
   ;; use write/bstscm! to write this to a string,
   ;; then re-read the string and compare
   (assert-equal (let ((str (with-output-to-string
                              (lambda ()
                                (write/bstscm! progs)))))
                   (call-with-input-string str
                     (lambda (p)
                       (let loop ((expr (read p)))
                         (if (eof-object? expr)
                             '()
                             (cons expr (loop (read p))))))))
                 progs))

 ;; The following test doesn't work properly, because the empty
 ;; emtries t3 and t4 are in an unspecified order (as of February
 ;; 2024, so we can't guarantee the order of the resulting \bibitem
 ;; output.  This is a neat but unimportant test, so skip it.
 #;(with-new-globals
  (let ((bst (resolve-file "plain.bst" ".bst" :error-if-not-found? #f)))
    ;;(eprintf "plain.bst -> ~a~%" bst)
    (if bst
        (let ((bibdata (parse-bibtex-file "bib-t01-simple.bib"))
              (bibstyle (parse-bst-file bst)))
          (let ((bbl (cond
                      ((and bibdata bibstyle)
                       (with-output-to-string
                         (lambda ()
                           (run-bst-program bibstyle bibdata))))
                      (else "error parsing bib-t01-simple.bib"))))
            (assert-equal bbl
                          (string-join '("preamble string"
                                         "\\begin{thebibliography}{1}"
                                         ""
                                         "\\bibitem{t4}"
                                         ""
                                         ""
                                         "\\bibitem{t3}"
                                         ""
                                         ""
                                         "\\bibitem{t1-1}"
                                         "Sample~{Author} and First~Last."

 "\\newblock Article title."
                                         "\\newblock {\\em Irreproducible Results}, 1999."
                                         "\\newblock Final note."
                                         ""
                                         "\\bibitem{T1-2:UPPERCASE}"
                                         "Another~Author."
                                         "\\newblock {\\em Book title}."
                                         "\\newblock Someone, January 2000."
                                         ""
                                         "\\end{thebibliography}\n")
                                       "\n"))))
        (eprintf "no plain.bst found -- test skipped~%"))))
 )

(exit/failures)