;; Functions loaded when we are expecting to parse a .bst file.
;; These implement the semantic actions of parse-bst.y
;;
;; The parse of the .bst file produces a list of expressions such as
;; '(comment ...), or '(entry ...), and so on, corresponding to the
;; various structures within the .bst file.  These are 'compiled' by
;; RUN-BST-PROGRAM into a set of functions (list-of-entries ->
;; list-of-entries), and then the entries parsed from the .bib file
;; are chained through this list.
;;
;; The most interesting of those functions is '(iterate...), which
;; applies a given function to each of the entries in that list, for
;; side-effects.  That function will typically be call.type$
;;
;; We implement the stack-based .bst language by creating a number of
;; three-argument functions, implementing both built-in BST functions
;; such as `+` and `if$`, and user-defined functions.  The `{...}`
;; blocks within functions are also implemented as such functions.
;; The three arguments are a context, a stack, and a ‘call-stack’.
;; See bst-wrap-function/stack for an explanation of these.
;;
;; I am somewhat inconsisent about which functions are starred
;; -- loosely indicating internal-only -- and which are not.  In
;; principle (and once I get modules sorted out), very of these
;; functions will be 'public'.
;;
;; Note: s7 takes 'a to be equivalent to (#_quote a), not (quote a).
;;
;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2023 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

(define *requires-implementation-functions*
  '(parse-bst-source**))

(module 'bibtex 'authors 'unicode 'subtex)
(define-macro (%module-verbosity-flag%) 16)

(define/provide (parse-bst-file . args)
  #"""
    `parse-bst-file : [filename] -> list?` :
    Parse a .bst file, returning a 'compiled' version of it.
    This is not of much general use, since the only thing which can use the
    result is internal functions in this module, but it may be of interest.

    If the filename is absent or `#f`, then parse from stdin.

    I have vague plans to create a decompiler, to turn the output of this
    into a .bst file, so that it would be possible to edit the result here
    and create a modified or derivative .bst file without insane pattern-matching.
  """
  (cond ((null? args) (parse-bst-source** #t #f))
        ((string? (car args)) (parse-bst-source** #t (car args)))
        ((not (car args)) (parse-bst-source** #t #f))
        (else (beastie-error "parse-bst-file: argument must be a string or #f, not ~s" (car args)))))
(define/provide (parse-bst-string input)
  "(parse-bst-string input) : as with parse-bst-file, but parsing from a string argument (mostly for testing)"
  (if (string? input)
      (parse-bst-source** #f input)
      (beastie-error "parse-bst-string: argument must be a string, not ~s" input)))

;; depending on the value of *verbosity* _at compilation time_
;; we include or skip debug code
(define-macro (debug fmt . args)
  (if (> *verbosity* *verbosity-info*)
      `(for-each (λ (msg)
                   (format (current-error-port) "## ~a~%" msg))
                 (string-split (format #f ,fmt ,@args) #\newline))
      '()))

;; For the commands, see the btxhak document
(define (bst:make-comment text)
  `(comment ,text))
(define (bst:make-entry fields integers strings)
  `(entry ,fields ,integers ,strings))
(define (bst:make-execute function-name line-number)
  (list 'execute function-name line-number: line-number))
(define (bst:make-function function-name block line-number)
  (list 'function
        function-name
        block
        line-number: line-number))
(define (bst:make-block block line-number)
  `(block ,block line-number: ,line-number))
(define (bst:make-integers symbol-list)
  `(integers ,symbol-list))
(define (bst:make-iterate function-name line-number)
  (list 'iterate
        function-name
        line-number: line-number))
(define (bst:make-macro name string-value)
  (list 'macro name string-value))
(define (bst:make-read line-number)
  `(read))
(define (bst:make-reverse function line-number)
  (list 'reverse
        function
        line-number: line-number))
(define (bst:make-sort line-number)
  `(sort line-number: ,line-number))
(define (bst:make-strings list-of-symbols)
  `(strings ,list-of-symbols))
(define (bst:make-quote symbol)
  `(#_quote ,symbol))

(define/provide (write/bstscm! program)
  "A still-rudimentary prettyprinter for a bstscm program (really for internal use only at present)"
  (define in
    (let ((s (make-string 80 #\space)))
      (string-set! s 0 #\newline)
      (lambda (n)
        (if (< n 0)
            "\n"
            (substring s 0 (+ (* n 2) 1))))))
  (define (w! pl level prefix)
    (cond ((null? pl))
          ((eqv? (car pl) ':=)
           (printf "~a:=" prefix)
           (w! (cdr pl) level (in level)))
          ((keyword? (car pl))
           (printf "~a~s ~s" (in (+ level 1)) (car pl) (cadr pl))
           (w! (cddr pl) level " "))
          ((and (list? (car pl))
                (not (null? (car pl)))
                (eqv? (caar pl) '#_quote))
           (printf "~a'~s" prefix (cadar pl))
           (w! (cdr pl) level " "))
          ((and (>= (length pl) 4)
                (eqv? (list-ref pl 3) 'if$))
           (w! (list (list-ref pl 0)) level prefix)
           (w! (list (list-ref pl 1)) (+ level 1) (in (+ level 1)))
           (w! (list (list-ref pl 2)) (+ level 1) (in (+ level 1)))
           (printf "~aif$" (in level))
           (w! (list-tail pl 4) level (in level)))
          ((and (>= (length pl) 3)
                (eqv? (list-ref pl 2) 'while$))
           (w! (list (list-ref pl 0)) level prefix)
           (w! (list (list-ref pl 1)) (+ level 1) (in (+ level 1)))
           (printf "~awhile$" (in level))
           (w! (list-tail pl 3) level (in level)))
          ((list? (car pl))
           (printf "~a(" (in level)) ;(in (+ level 1)))
           (w! (car pl) (+ level 1) "")
           (display ")")
           (w! (cdr pl) level " "))
          (else
           (case (car pl)
             ((function)
              (printf "~a ~a" (car pl) (cadr pl))
              (w! (cddr pl) (+ level 1) "");(in (- level 1)))
              (display ""))
             ;; ((if$ while$)
             ;;  (printf "~a~s" (in level) (car pl))
             ;;  (w! (cdr pl) level (in level)))
             (else (printf "~a~s" prefix (car pl))
                   (w! (cdr pl) level " "))))))
  (for-each (lambda (element)
              ;(printf "# ~s~%" element)
              (display "(")
              (w! element 0 "")
              (display ")")
              (newline))
            program))

;; The call-stack is a list of (cons function-name line-number),
;; most recent first, tracking the sequence of calls to this point.
;; The function-name will be #f if this is an (anonymous) block.
;; The line-number will be #f if this is an internal function.
(define (call-stack->string call-stack)
  (string-join
   (map (lambda (p)                     ;show block name and line number; anonymous blocks as "{}"
          (if (cdr p)
              (format #f "~a:~a" (or (car p) "{}") (cdr p))
              (format #f "~a" (or (car p) "{}"))))
        call-stack)
   " <- "))

;; beastie-error/call-stack : call-stack [symbol?] string? ...
(define (beastie-error/call-stack call-stack fmt . args)
  (let ((msg
         (cond ((string? fmt) (apply sprintf (cons fmt args)))
               ((symbol? fmt) (apply sprintf args))
               (else
                (eprintf "Weird call to beastie-error/call-stack, with fmt=~s" fmt)
                (apply sprintf args))))
        (subtag (if (symbol? fmt)
                    fmt
                    'bst-stack)))
    (beastie-error/assoc msg
                         `((subtag . ,subtag)
                           (calls . ,(call-stack->string call-stack))))))

;; format a stack-element for printing
(define (stack-print-element se)
  (if (block? se)
      (object->string se)
      (sprintf "~s" se)))
;; print the stack to a string, for debugging purposes
(define (stack-print-stack/debug s)
  (if (null? s)
      "    <empty>"
      (string-join (map (λ (se)
                          (sprintf "    ~a" (stack-print-element se)))
                        s)
                   "\n")))

;; BTX-MAKE-BLOCK* : (listof (or/c symbol? ustring? integer?)) [integer?] -> block?
;; Construct a block from a list of items parsed from the input.
;; If a second argument is present, it's a line number
;;
;; The 'block' is an openlet which contains
;; (a) the function, f, which is called when this block is called, and
;; (b) the symbol object->string, which is called when this block is to be written
;; out (for debugging or error tracing).
(define* (btx-make-block* block (line-number #f))
  (let ((compiled-block
         ;; remove any (comment ...) forms from the block
         (filter values
                 (map (lambda (bi)
                        ;; discard comments, preserve (quote sym), compile blocks
                        (cond ((and (pair? bi) (eqv? (car bi) 'comment)) #f)
                              ((and (pair? bi) (eqv? (car bi) '#_quote) bi))
                              ((list? bi) (btx-make-block* bi line-number: line-number))
                              (else bi)))
                      block)))
        (block-name #f))
    (openlet
     (inlet 'isblock? #t
            'f (λ (context stack call-stack)
                 (btx-execute-block* context
                                     compiled-block
                                     stack
                                     `((,block-name . ,line-number) . ,call-stack)))
            'name (λ arg
                    (if (null? arg)
                        block-name
                        (set! block-name (car arg))))
            'ln line-number
            'object->string (λ (obj . arg) ;method
                              (let ((the-line-number (obj 'ln))
                                    (name (or ((obj 'name)) "<anonymous>"))
                                    (block/print
                                     (if (> (length compiled-block) 4)
                                         (append (take compiled-block 4) '(...))
                                         compiled-block)))
                                (if the-line-number
                                    (sprintf "<block:~a:~a ~s>"
                                             name the-line-number block/print)
                                    (sprintf "<block:~a ~s>"
                                             name block/print))))))))
(define (block? x)
  (and (openlet? x)
       (defined? 'isblock? x #t)))
(define (block-func b)
  (unless (block? b) (beastie-error 'bst "block-func given ~s, expected block" b))
  (b 'f))
(define (block-lineno b)
  (unless (block? b) (beastie-error 'bst "block-lineno given ~s, expected block" b))
  (b 'ln))
(define (block-get-name b)
  (unless (block? b) (beastie-error 'bst "block-get-name given ~s, expected block" b))
  ((b 'name)))
(define (block-set-name! b newname)
  (unless (block? b) (beastie-error 'bst "block-set-name! given ~s, expected block" b))
  ((b 'name) newname)
  b)

;; Given a procedure or block, return a procedure.
;; Anything else, return #f.
;; The explicit test for an openlet? is because s7 (rather surprisingly to me)
;; returns #t when PROCEDURE? is applied to an openlet.
(define (get-function f/b)
  (cond ((procedure? f/b)
         (if (openlet? f/b)
             #f
             f/b))
        ((block? f/b) (block-func f/b))
        (else #f)))

;; see parse-bst.y
(define (make-bst-function-call* function-name lineno)
  (list 'func function-name line-number: lineno))

;; There are two namespaces managed in this file, one 'global', containing the
;; functions, macros, and the global variables declared with INTEGERS
;; and STRINGS, and the other local to an entry, containing the entry fields, and
;; the per-entry variables defined in the .bst ENTRY command.  In both cases,
;; the string and integer variables are typed and can only be assigned
;; once declared, and some values -- functions in one case and fields
;; in the other -- are read-only.  These are both managed
;; within the 'context' which is passed around, so that 'global'
;; variables are global only within a context.  See MAKE-CONTEXT below.

(define (bst-variable-get context k)
  (or (bst-variable-get/local context k)
      (bst-variable-get/global context k)))

;; Set current-entry field k to v.
;; If k isn't an entry field, return #f rather than failing
;; (because this might be a global variable).
(define (bst-variable-set/local! context k v)
  ;(eprintf "bst-variable-set/local!: ~s -> ~s~%" k v)
  (varlet (curlet) context)
  (cond ((not (symbol? k))
         (beastie-error 'bst "set-local! with non-symbol key ~s" k))
        ((local-variable-get-type k)
         => (lambda (info)
              (cond ((symbol? info)
                     (beastie-error 'bst
                                    "bst-variable-set/local!: can't set variable ~s (~s)"
                                    k info))
                    ((info v)
                     (entry-set-local-variable! *entry* k v)) ;...and return non-#f y
                    (else
                     (beastie-error 'bst
                                    "bst-variable-set/local!: bad value ~s for variable ~s"
                                    v k)))))
        (else #f)))

(define (bst-variable-get/local context k)
  ;; Return the value local to an entry, if there is an *entry* defined in the context,
  ;; Return #<undefined> if it's a known *FIELD* but not set,
  ;; and #f if unknown.
  ;; We use the keys 'entry-cite$ and 'entry-type$ as ways of looking up
  ;; the key and type (we can't use 'cite$ and 'type$ because they shadow
  ;; the same-named functions.
  ;;
  ;; This interacts with the ITERATE macro in run-bst-program,
  ;; which is what places the 'current entry' into *entry* in the context.
  (varlet (curlet) context)
  (and (defined? '*entry*)
       (case k
         ((entry-cite$) (entry-key *entry*))
         ((entry-type$) (entry-type *entry*))
         (else
          (cond ((not *entry*)
                 ;; this is probably an error somewhere, but it also can
                 ;; happen in the low-level test-suite, and it seems
                 ;; reasonable to regard it as harmless here
                 #f)
                ((entry-field *entry* k
                              ;; XXX this lookup argument has
                              ;; disappeared from entry-field:
                              ;; lookups now global!
                              #;(λ (s)
                                (and (symbol? s)
                                     (bst-variable-get context s)))))
                ((entry-get-local-variable *entry* k))
                ((local-variable-get-type k) #<undefined>)
                                        ;((bst-variable-type/global *entry* k) #<undefined>)
                (else #f))))))
;(trace! bst-variable-get/local)
#;(define (bst-variable-get/local context k)
  (let ((res (bst-variable-get/local* context k)))
    (eprintf "bst-variable-get/local: ~s -> ~s~%" k res)
    res))

;; STRING->AUTHORLIST : string? -> (listof author?)
;; Parse a given string as an authorlist, and cache it.
;; Although this will surely be one of the entry fields, we don't have to
;; care whether it is or not.
;;
;; Note: parse-author-list has an optional second 'location' argument.
;; I plan to add more provenance/location information before long, so
;; this can be used here.
(define string->authorlist
  (let ((*h* (make-hash-table 8 string=?)))
    (lambda (s)
      (or (*h* s)
          (let ((al/empty (or (parse-author-list s) "")))
            ;; if parse-author-list returns false, set the result to ""
            ;; (we don't need to print a warning here, since that's
            ;; already happened whilst parsing
            (hash-table-set! *h* s al/empty)
            al/empty)))))

;; The functions here manipulate a stack, formed from a list, with the
;; top of the stack at the front of the list.
;; Each of the functions defined from the macro BST-WRAP-FUNCTION/STACK
;; takes
;;
;;    * a context (a let?),
;;    * a stack (as a list?), and
;;    * a call-stack (as (listof (cons label (or/c linenumber #f))))
;;
;; as arguments, and returns a stack.

;; GET-FROM-STACK* : symbol? list? list? (list/c (any -> boolean?))
;; Given a stack, removes a number of stack elements corresponding to
;; the length of the list PREDS, and returns the shortened stack, and
;; those entries, as multiple values.  The entries are returned in
;; reverse order of being popped: that is, if the stack was '(1 2 3 4),
;; what would be returned would be (values 4 3 2 1).
;;
;; If a predicate is #f, then any stack element is accepted.
;;
;; If the stack is too short, or if a stack element is not the
;; expected type, then throw an error tagged 'stack.
;;
;; The btxhak document (sect.5.3) says that wrong types should result
;; in the stack being left with 0 or "" as appropriate.
;; I considered implementing this specifically for substring$
;; (because I think this case appears in one of the standard styles)
;; but perhaps I should implement this in general in this procedure.
;; Alternatively, I could regard it as an expediency of BibTeX that's best ignored.
;; At present, type errors result in throwing beastie-error.
(define (get-from-stack* name stack call-stack preds)
  (debug "get-from-stack* for ~s:~%  stack=~%~a~%  call-stack=~s~%  preds=~s"
         name
         (stack-print-stack/debug stack)
         call-stack preds)
  (let loop ((rval '())
             (s stack)
             (req preds)
             (i 1))
    (cond ((null? req)
           (debug "  -> ~s" (cons s rval))
           (apply values (cons s rval)))
          ((null? s)
           (beastie-error/call-stack call-stack "stack empty when calling ~a" name))
          ((or (not (car req))
               ((car req) (car s))) (loop (cons (car s) rval)
                                          (cdr s)
                                          (cdr req)
                                          (+ i 1)))
          (else
           (debug "get-from-stack: error with s=~s~%" s)
           (beastie-error/call-stack
            call-stack
            "calling ~s with stack ~s: expected ~s for item ~s, got ~s"
            name stack (car req) i (car s))))))

;; Wrap a function for use on a stack.
;;
;; The function must be (let? s1? ... sn? -> (or/c (listof/c s?) s? '()),
;; where each of the arguments sN? is an allowed type on the stack,
;; which were popped from the stack in order s1,...sn.  N can be zero.
;;
;; Called as (wrap-function/stack exposed-name f pred1? ... predN?),
;; this expands to a function called "btx$<exposed-name>" with
;; signature (let? stack? call-stack? -> stack?).
;;
;; In the resulting function,
;;
;;   * arg-1 is a 'context', which is a let
;;     which contains 'global variables', as far as bst is concerned.
;;
;;   * arg-2, the working stack, is the stack which is manipulated by the
;;     functions, and consists of strings, integers, and functions (see
;;     the procedure STACK-VALUE?).
;;
;;   * arg-3, the call-stack, is a trace of the calls leading to that point, and
;;     consists of a list of `(location . line-number)` pairs.  Each of
;;     these functions manipulates the (first) stack, and returns a new
;;     possibly modified stack.
;;
;; This generated function applies the function F to the current
;; context, and N values popped from the stack.  This also registers
;; "btx$<exposed-name>" as the name within the BST program which
;; refers to this function (Hmm: is this a monad?).
;;
;; If the return value of F is a non-list value, then it is pushed onto the stack;
;; if it is nil, then nothing is pushed;
;; and if it is a non-empty list then the values in the list are pushed in order
;; (ie, if the stack was '(1 2) before, and the function returned
;; '("a" "b"), then the stack after would be '("b" "a" 1 2).
;;
;; The function takes, and passes on, a call-stack, consisting of the
;; stack of functions called up to this point.  This is for the
;; benefit of error messages and debugging.
(define-macro (bst-wrap-function/stack exposed-name
                                       f
                                       . preds)
  (let ((implementation-name (string->symbol (sprintf "btx$~a" exposed-name))))
    `(begin
       (define (,implementation-name context stack call-stack)
         ((lambda (s . args) ;called with the stack post-pop, and the objects popped
            (catch 'beastie
                   (lambda ()
                     (let ((res (apply ,f (cons context args))))
                       (debug "applying ~s to~%  args: ~s~%  stack:~%~a~%  -> ~s"
                              ,implementation-name
                              args
                              (stack-print-stack/debug s)
                              res)
                       (cond ((null? res)	s) ;s7 null? returns #f for non-lists
                             ((list? res)	(append (reverse res) s))
                             (else		(cons res s)))))
                   (lambda (tag info)
                     ;; info is ("string" ((key1 . value1) ...))
                     ;; If the alist has a 'calls key, then re-throw (tag info) unchanged.
                     ;; If it does not, then re-throw
                     ;; (tag ("string" ((calls . "loc") (key1 . value1) ...)))
                     ;; where "loc" is the call-stack->string value of here
                     (debug "wrap catch: tag=~s  info=~s" tag info)
                     (let* ((msg (car info))
                            (extra (cadr info))
                            (i+ (if (assq 'calls extra)
                                    info
                                    (let ((this-item (cons (#_quote ,exposed-name) #f)))
                                      `(,msg
                                        ((calls . ,(call-stack->string (cons this-item call-stack)))
                                         . ,extra))))))
                       (apply throw (cons tag i+))))))
          (get-from-stack* (#_quote ,exposed-name)
                           stack
                           (cons (cons (#_quote ,exposed-name) #f) call-stack)
                           (list . ,preds))))
       (btx-function-list* (#_quote ,exposed-name) ,implementation-name))))

;;; Functions: arithmetic functions, first
(define btx-function-list*
  (let ((*l* '()))
    (lambda rest
      (case (length rest)
        ((0) *l*)
        ((2) (set! *l* `((,(car rest) . ,(cadr rest)) . ,*l*)))
        (else (beastie-error 'bst "unexpected call to btx-function-list*"))))))

(bst-wrap-function/stack >
                         (lambda (context v2 v1)
                           (if (> v2 v1) 1 0))
                         integer? integer?)
(bst-wrap-function/stack <
                         (lambda (context v2 v1)
                           (if (< v2 v1) 1 0))
                         integer? integer?)
(bst-wrap-function/stack =
                         (lambda (context v2 v1)
                           (cond ((and (integer? v1) (integer? v2))
                                  (if (eqv? v1 v2) 1 0))
                                 ((and (ustring? v1) (ustring? v2))
                                  (if (ustring=? v1 v2) 1 0))
                                 (else
                                  (beastie-error 'bst
                                                 "arguments to = must be both string or both integer; got (~s ~s)"
                                                 v1 v2))))
                         #f #f)
(bst-wrap-function/stack - (λ (ctx n1 n2) (- n1 n2)) integer? integer?)
(bst-wrap-function/stack + (λ (ctx n1 n2) (+ n1 n2)) integer? integer?)

(bst-wrap-function/stack * (λ (ctx s1 s2) (ustring-append s1 s2)) ustring? ustring?)

(bst-wrap-function/stack add.period$
                         (λ (ctx s)
                           ;; btxhak.pdf doesn't say what we should do if the argument is "".
                           ;; Decision: return the input string unchanged.
                           (if (ustring=? s #"")
                               s
                               (let ((last-char (ustring-ref s (- (ustring-length s) 1))))
                                 (case last-char
                                   ((#x21 #x2e #x3f) s) ; one of [!.?]
                                   (else (ustring-append s #\.))))))
                         ustring?)

;; The btxhak documentation isn't terribly specific about how
;; call.type$ is called (because it doesn't have to be).  Here, we
;; assume that it is called with the current context having been lodged
;; as the 'bst-current-entry'.
;;
;; Although btxhak doesn't say so explicitly, this probably shouldn't be called
;; from a .bst program other than via the ITERATE or REVERSE
;; functions.  However it seems sensible to make that not fail, which
;; is why it has the same function signature, (stack? -> stack?) as
;; other functions.  Despite this, the per-entry functions are called with an empty
;; stack.
(define (btx-call-type context dummy-stack prior-call-stack)
  (let ((f/b (or (bst-function/bstname context
                                       (bst-variable-get/local context 'entry-type$))
                 (bst-function/bstname context
                                       'default.type))))
    (if f/b
        (let ((call-stack `((call.type$ . #f) . ,prior-call-stack)))
          (let ((result-stack ((get-function f/b) context '() call-stack))) ;this result-stack should be '()
            (unless (null? result-stack)
              (beastie-error/call-stack
               call-stack
               "Stack not empty [~a] after calling ~s (line ~a) on entry ~s"
               (string-join (map stack-print-element result-stack))
               (bst-variable-get/local context 'entry-type$)
               (or (and (block? f/b) (block-lineno f/b)) "unknown")
               (bst-variable-get/local context 'entry-cite$)))))
        (beastie-error/call-stack prior-call-stack
                                  "no function '~a', and no function 'default.type'"
                                  (bst-variable-get/local context 'entry-type$)))
    dummy-stack))
(btx-function-list* 'call.type$ btx-call-type)

;;;; Case manipulations

;; Case changing.
;; These functions are mostly for the author-wrangling in authors.scm,
;; but could be of more general utility.

;; This function implements the behaviour of the btxhak change.case$ function.
;; That function upper-, lower-, or title-cases characters at
;; brace-level 0, with the exceptions noted below in titlecase-string.
(define (case-mutate-string/bst* f us)
  (bstring->ustring
   (list->bstring
    (map (λ (i0)
           (if (integer? i0)
               (f i0)
               i0))
         (ustring-iterator/bstrings us)))))

(define/provide (uppercase-string/bst us)
  #"""`(uppercase-string/bst us)` : Uppercase a ustring, returning a copy.
  The function will mutate characters, using `uchar-upcase`
  _at brace level 0 only_, passing unchanged any characters enclosed within braces.

  This version is intended to be compatible
  with the `.bst` definition of uppercasing.
  See also `titlecase-string/bst`."""
  (cond ((not us) #f)
        ((string? us)
         (case-mutate-string/bst* uchar-upcase (make-ustring us)))
        ((ustring? us)
         (case-mutate-string/bst* uchar-upcase us))
        (else
         (beastie-error "uppercase-string/bst: argument should be a string or #f, not ~s" us))))

(define/provide (lowercase-string/bst us)
  #"""`(lowercase-string/bst us)` : Lowercase a ustring, returning a copy.
  The function mutates characters using `uchar-downcase`,
  similarly to `uppercase-string/bst`.

  See also `titlecase-string/bst`."""
  (cond ((not us) #f)
        ((string? us)
         (case-mutate-string/bst* uchar-downcase (make-ustring us)))
        ((ustring? us)
         (case-mutate-string/bst* uchar-downcase us))
        (else
         (beastie-error "lowercase-string/bst: argument should be a string or #f, not ~s" us))))
;; btxhak, on change.case$
;;
;;   If the first literal is the string ‘t’, it converts to lower case
;;   all letters except the very first character in the string, which
;;   it leaves alone, and except the first character following any
;;   colon and then nonnull white space, which it also leaves alone
(define/provide (titlecase-string/bst us)
  #"""`(titlecase-string/bst us)` : return a copy of the ustring `us`, converted to titlecase.
  This version is intended to be compatible
  with the definition of titlecasing for BibTeX `.bst` files, the documentation
  for which describes a slightly idiosyncratic definition of ‘titlecase’.
  The key peculiarities are:

    * This changes only characters at brace-level 0.
    * For titlecase, the `btxhak.pdf` document says: ‘If the first literal is the
      string ‘t’, it converts to lower case all letters except the very first character
      in the string, which it leaves alone, and except the first character following
      any colon and then nonnull white space, which it also leaves
      alone.’

  That is, for titlecase, the function will _not_ uppercase anything,
  since the BibTeX specification implies that entries are created in
  uppercase or titlecase, so that titlecasing consists only of
  lowercasing selected letters.

  For consistency, if the argument is `#f`, then this returns `#f`,
  and if the function is passed a string?,
  then (for convenience/consistency) it will be converted to a ustring? before being processed."""

  (cond ((not us) #f)
        ((string? us) (titlecase-string/bst* (make-ustring us)))
        ((ustring? us) (titlecase-string/bst* us))
        (else
         (beastie-error "titlecase-string/bst: argument should be a ustring or #f, not ~s" us))))

(define (titlecase-string/bst* us)
  (let ((i (ustring-iterator/bstrings us)))
    ;; The flag colon? indicates whether we're leaving characters alone,
    ;; because we're following a colon.
    ;; Start with colon? #t, so that we leave the first character alone.
    (let loop ((colon? #t)              ;#t, #f, or 'maybe
               (result '()))
      (let ((i0 (i)))
        (cond ((eof-object? i0)
               (bstring->ustring
                (list->bstring
                 (reverse! result))))
              ((or (bstring? i0)
                   (eqv? i0 'nbsp))
               (loop #f (cons i0 result)))
              ;; past this point, i0 must be an integer
              ((= i0 #x3a)              ;colon
               (loop 'maybe ;maybe -> #t, if this is followed by whitespace
                     (cons i0 result)))
              ((eqv? colon? 'maybe)
               (if (char-space? i0)
                   (loop #t
                         ;; leave this character alone, but note that we will
                         ;; downcase the next non-whitespace character
                         (cons i0 result))
                   (loop #f
                         (cons (uchar-downcase i0) result))))
              (colon?                   ;i0 is not to be downcased
               (loop (char-space? i0)   ;keep #t as long as this is a space
                     (cons i0 result)))
              (else
               (loop #f
                     (cons (uchar-downcase i0) result))))))))

(define (btx-change-case* s fmt)
  ;; ustring? ustring? -> ustring?
  (case (ustring->symbol fmt)
    ((t T) (titlecase-string/bst s))
    ((l L) (lowercase-string/bst s))
    ((u U) (uppercase-string/bst s))
    (else ;; should write a warning here...
     (print-warning "change-case: fmt=~s is unrecognised" fmt)
     s)))(define/provide (string->page-range str)
  #"""`(string->page-range str)` :
  Break a string page-range into the quoted page numbers.

    * Given "1", return '("1" . single).
    * Given a string such as "1-2", "1--2" (two hyphens) or "1–2" (Unicode en-dash),
      return '("1" . "2").
    * Given "1-" or "1+", return '("1" . inf).

  If the argument is not a string, or if there are no digits present, return #f.

  Argument strings such as "x1-2" or "1-2-3" are invalid as a page range
  and will produce `#f`."""
  (define range (regexp "^([0-9]+)([-–]+([0-9]*)|\\+)?$"))
  (and (string? str)
       (let ((m (regexp-match range str)))
         (and m
              (let ((start-page      (cadr m))
                    (range-indicator (caddr m))
                    (end-page        (cadddr m)))
                (cond ((not range-indicator)  (cons start-page 'single))
                      ((not end-page)         (cons start-page 'inf))
                      ((string=? end-page "") (cons start-page 'inf))
                      (else                   (cons start-page end-page))))))))


;; EN-DASHIFY : string? -> string?
;; EN-DASHIFY : (not string?) -> #f
;; Replace '-' or '--' in the string with en-dash "–"
(define/provide (en-dashify s)
  #"""`(en-dashify s)` : Replace '-' or '--' or Unicode en-dash in the string with en-dash '–'.
  BibTeX permits "1+" to indicate a start-of-range, so that has to turn into a dash.
  If the argument is not a string, evaluates to #f"""
  (let ((range (string->page-range s)))
    (cond ((not range) #f)
          ((symbol? (cdr range))
           (if (eqv? (cdr range) 'inf)
               (string-append (car range) "–")
               (car range)))
          (else (string-append (car range) "–" (cdr range))))))

;; This seems redundant, given string->page-range -- should I make it a built-in function?
;; (define/provide (first-page-number s)
;;   #"""(first-page-number s): Givan a string containing a page range, return the start-page.
;;   If S is not a string, return #f; if the string doesn't start with digits, return ""."""
;;   (let ((range (string->page-range s)))
;;     (if range
;;         (car range)
;;         #f)))

;; here, we test the type of the arguments explicitly, since btxhak
;; specifies behaviour for these being the wrong types.
(bst-wrap-function/stack change.case$
                         (lambda (context s fmt)
                           (if (and (ustring? s) (ustring? fmt))
                               (btx-change-case* s fmt)
                               (begin
                                 (print-warning "change-case: format ~s and string ~s should both be strings" fmt s)
                                 #"")))
                         #f #f)

(define (btx-chr-to-int* context s)
  ;; Pops the top (string) literal, makes sure it’s a single character,
  ;; converts it to the corresponding ASCII integer, and pushes this integer.
  (if (= (ustring-length s) 1)
      (ustring-ref s 0)
      (beastie-error 'bst
                     "chr.to.int$: string ~s is not of length 1" s)))
(bst-wrap-function/stack chr.to.int$ btx-chr-to-int* ustring?)

(define (btx-int-to-chr* context i)
  ;; Pops the top (integer) literal, interpreted as the ASCII
  ;; integer value of a single character, converts it to the
  ;; corresponding single character string, and pushes this string.
  (make-ustring i))
(bst-wrap-function/stack int.to.chr$ btx-int-to-chr* integer?)

(define (btx-int-to-str* context i)
  (make-ustring (sprintf "~a" i)))
(bst-wrap-function/stack int.to.str$ btx-int-to-str* integer?)

(bst-wrap-function/stack cite$
                         (λ (context)
                           ;; turn the citation into a string if the context
                           ;; includes an *entry*, but don't fail if not
                           ;; (we probably shouldn't be calling this function
                           ;; in the latter case)
                           (cond ((bst-variable-get/local context 'entry-cite$)
                                  => symbol->ustring)
                                 (else #f))))

;; FIXME (maybe): btxhak says that type$ "pushes the null string if
;; the type is either unknown or undefined."  That seemd an odd and
;; unhelpful default, and I'm not sure whether I should do the same,
;; or just silenly `fix' this.
(bst-wrap-function/stack type$
                         (λ (context)   ;see above
                           (cond ((bst-variable-get/local context 'entry-type$)
                                  => symbol->ustring)
                                 (else #f))))

;; The definition of empty$ in btxhak is:
;;
;;     empty$ Pops the top literal and pushes the integer 1 if it’s a
;;     missing field or a string having no non-white-space characters,
;;     0 otherwise.
;;
;; I think the only thing that can be popped when this is called is a
;; literal, so I don't include any test for that.  This empty$
;; therefore pops anything, and pushes true if it's #<undefined> or an
;; all-whitespace string.
;;
;; A regexp version
;; (define btx-empty*
;;   (with-let (sublet *libc*)
;;             (let ((re (let ((r (regex.make)))
;;                         (regcomp r "^[[:space:]]*$" 0)
;;                         r)))
;;               (lambda (s)
;;                 (printf "Comparing ~s with re ~s -> ~s~%" s re (regexec re s 0 0))
;;                 (if (or (eqv? s #<undefined>)
;;                         (= (regexec re s 0 0) 0))
;;                     1
;;                     0)))))
(define (btx-empty* context x)
  (cond ((eqv? x #<undefined>) 1)
        ((integer? x) 0)
        ((ustring? x)
         (let ((i (make-iterator x)))
           (let loop ()
             (let ((i0 (i)))
               (cond ((eof-object? i0) 1)
                     ((char-space? i0) (loop))
                     (else 0))))))
        (else (beastie-error 'bst "empty$: Unexpected item popped: ~s" x))))
(bst-wrap-function/stack empty$ btx-empty* #f)

(bst-wrap-function/stack missing$
                         (lambda (context s)
                           (if (eqv? s #<undefined>) 1 0))
                         #f)

(bst-wrap-function/stack duplicate$ (lambda (context x) (list x x)) #f)
(bst-wrap-function/stack pop$ (lambda (context x) '()) #f)
(bst-wrap-function/stack quote$
                         (let ((single-quote #"\""))
                           (lambda (context) single-quote)))

(define (btx-skip context x call-stack) x)
(btx-function-list* 'skip$ btx-skip)

(bst-wrap-function/stack swap$ (lambda (context a b) (list b a)) #f #f)
(bst-wrap-function/stack top$
                         (lambda (context x)
                           ;; we include a newline, because that's what BibTeX seems to do
                           (eprintf "~a~%" x)
                           '())
                         #f)

(define (show-stack* stack call-stack new-top)
  (eprintf "Stack: @~a~%"
           (cond ((null? call-stack) "top")
                 ((caar call-stack) (sprintf "~a:~a" (caar call-stack) (cdar call-stack)))
                 (else (sprintf "line ~a" (cdar call-stack)))))
  (let loop ((s stack)
             (i 0))
    (if (null? s)
        (begin
          (newline)
          new-top)
        (begin
          (eprintf "  ~a: ~a~%" i (car s))
          (loop (cdr s) (+ i 1))))))

;; the .btx stack$ function: Pops and prints the whole stack.
(define (btx-stack context stack call-stack)
  (show-stack* stack call-stack '()))
(btx-function-list* 'stack$ btx-stack)

;; show.stack$$: a more useful function, which just displays it
(define (btx+show-stack context stack call-stack)
  (show-stack* stack call-stack stack))
(btx-function-list* 'show.stack$$ btx+show-stack)

(bst-wrap-function/stack warning$
                         (lambda (context s)
                           (print-warning "Warning: ~a" s)
                           '())
                         ustring?)

;; Printf support -- functions printf$$, printf.push$$ and printf.pop$$

;; `printf$$` : this pops a string format, and then pops as many
;; further objects as there are `~a` or `~s` format specifiers in the
;; string.  It then formats and outputs the format string and
;; arguments, replacing the format specifiers, from first to last, by
;; the items popped from the stack, in the _reverse_ order they were popped
;; (that is, from left to right, in the usual way of laying out a `.bst` file).
;; The format `~a` prints the item in a readable way, whereas `~s`
;; does so in a possibly variant way which makes it clearer what type
;; the object is.  The format string may also include `~~` or `~%` to
;; append a tilde or newline respectively.
;;
;; `printf.push$$` and `printf.pop$$` : by default, `printf$$` sends
;; its output to the same destination as `write$`, but this can be
;; adjusted.
;;
;; If `printf.push$$` is given a string argument, then it
;; names a file which will be created, and which will receive the
;; material written by `write$`, `newline$` and `printf$$`, until a
;; matching appearance of `printf.pop$$`.  That matching call will
;; return the output to what it was before, and leave the name of the
;; file on the stack.
;;
;; The function `printf.push$$` can also be given a numeric argument.
;; If this is `#1` or `#2`, then beastie redirects output to stdout
;; or the current error-port respectively, and `printf.pop$$` will
;; leave an indicative string on the stack.  If the argument is `#0`,
;; however, then output will be directed to a string, which is what
;; will be left on the stack by `printf.pop$$`.
;;
;; For example:
;;
;;     function {try.printing}
;;     {
;;       "Hello from try.printing" write$ newline$ %chatter as normal
;;
;;       "test.txt" printf.push$$      % redirect to file "test.txt"
;;       "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$$                  % leaves the filename on the stack
;;       "file was: " swap$ * write$ newline$ % ...printed
;;
;;       #0 printf.push$$              % write to a string
;;       "Going to a file" write$ newline$
;;       printf.pop$$                  % leaves the string on the stack
;;       "string was: " swap$ * write$ newline$ % ...displayed
;;     }

;; output stack: each item on this, apart form the first one, is a
;; cons of a port and (or/c thunk #f): write$, newline$, and printf$$
;; write to the port, and printf.pop$$ pops the stack, and calls the
;; thunk.  The first port is `#f` which we use to indicate the
;; `(current-error-port)` at the time of calling (as opposed to as of
;; this point).
(define *btx+printf-port-stack*
  (list (cons #f #f)))

;; printf.push$$
;; Pushes a printf destination.  If the argument is a string, it names
;; a file to be written to, until printf.pop$$.  If it is a symbol, it
;; names a bst string-type variable to be set to the accumulated value
;; in printf.pop$$.
(define (btx+printf-push context item)
  (cond ((ustring? item)
         (set! *btx+printf-port-stack*
               (cons (let* ((fn/string (ustring->string item :display))
                            (p (open-output-file fn/string)))
                       (cons p
                             (λ ()
                               (close-output-port p)
                               item)))  ;leave the filename on the stack
                     *btx+printf-port-stack*)))

        ((integer? item)
         ;; numeric destination:
         ;;   if #0, send to a string, and leave that on the stack
         ;;   if #1 or #2, send to current output/error port and leave a string on the stack
         ;; consider sending to open FDs if higher?
         (if (memq item '(0 1 2))
             (set! *btx+printf-port-stack*
                   (cons (case item
                           ((0)
                             (let ((p (open-output-string)))
                               (cons p
                                     (λ ()
                                       (let ((s (make-ustring (get-output-string p))))
                                         (close-output-port p)
                                         s)))))
                           ((1)
                            (cons (current-output-port)
                                  (λ ()
                                    #"*stdout*")))
                           (else
                            (cons (current-error-port)
                                  (λ ()
                                    #"*stderr*"))))
                         *btx+printf-port-stack*))
             (print-warning "Unexpected destination #~a for printf.push$$" item)))

        (else
         (print-warning "Unexpected argument ~s for printf.push$$" item)))
  '())
(bst-wrap-function/stack printf.push$$
                         btx+printf-push
                         #f)

;; printf.pop$$
;; Pop the printf stack.  If the stack is empty, print a warning, but
;; do not fail (this is mostly a debugging tool).
(define (btx+printf-pop context)
  (if (= (length *btx+printf-port-stack*) 1)
      (begin
        (print-warning "Attempt to pop empty printf$$ stack")
        '())
      (let ((thunk (cdar *btx+printf-port-stack*)))
        (set! *btx+printf-port-stack* (cdr *btx+printf-port-stack*))
        (list
         (if thunk
             (thunk)
             #"")))))
(bst-wrap-function/stack printf.pop$$
                         btx+printf-pop)

;; printf$$
;; Pops a format and an appropriate number of arguments, and formats
;; the latter appropriately.  The format specifiers can be `~a` or
;; `~s` to show a value, or `~%` or `~~` to escape the corresponding
;; characters.  The formats match the specifier, left to right, in the
;; order they are popped from the stack (ie, the first popped is the
;; first matched).
;;
;; Consider: "str" #1 printf$$ to send the printf specifically to
;; destination #1, whether this is stdout or a FD.
(define (btx+printf context stack call-stack)
  (define (count-args fmt)
    ;; returns either a list '(#f ...) containing
    ;; as many #f as there are ~a or ~s format specs,
    ;; or a ustring explanation if there is a format error
    (let ((i (make-iterator fmt)))
      (let loop ((predlist '()))
        (let ((i0 (i)))
          (cond ((eof-object? i0) predlist)
                ((= i0 #x7e)            ;tilde
                 (let ((i00 (i)))
                   (if (eof-object? i00)
                       #"trailing tilde in printf"
                       (let ((c (integer->char i00)))
                       (case c
                         ((#\a #\A #\s #\S)
                          (loop (cons #f predlist)))
                         ((#\% #\~)
                          (loop predlist))
                         (else
                          (make-ustring
                           (sprintf "unexpected format specifier ~~~a in: ~s"
                                    c fmt))))))))
                (else (loop predlist)))))))
  ((λ (s fmt)
     (let ((nargs (count-args fmt)))
       (if (ustring? nargs)
           (begin
             (print-warning "Bad printf format: ~a" nargs)
             s)
           ((lambda (s . args)
              (apply format
                     (cons (or (caar *btx+printf-port-stack*)
                               (current-output-port))
                           (map (λ (x)
                                  (if (ustring? x)
                                      (ustring->string x :display)
                                      x))
                                (cons fmt args))))
              s)
            (get-from-stack* 'btx+printf s call-stack nargs)))))
   (get-from-stack* 'btx+printf stack call-stack (list ustring?))))
(btx-function-list* 'printf$$ btx+printf)

(bst-wrap-function/stack num.names$
                         (lambda (context s)
                           (let ((al (string->authorlist s)))
                             (length al)))
                         ustring?)

;; format.name$: the index is 1-based.
;; If the index is out of range, we print a warning and push the first name string
(define (btx-format-name* context names index fmt)
  (let* ((al (string->authorlist names))
         (name (if (and (> index 0) (<= index (length al)))
                   (list-ref al (- index 1))
                   (begin
                     (print-warning "Index ~a is out of range for namelist ~a" index names)
                     (list-ref al 0)))))
    (format-name (parse-fmtstring fmt) name)))
(bst-wrap-function/stack format.name$
                         btx-format-name*
                         ustring? integer? ustring?)

;; setting with :=
(bst-wrap-function/stack :=
                         (lambda (context val sym)
                           (unless (or (bst-variable-set/local! context sym val)
                                       (bst-variable-set/global! context sym val))
                             (beastie-error 'bst
                                            "~s isn't a global or local variable" sym))
                           '())
                         symbol? (lambda (x) (or (ustring? x) (integer? x))))

(define (procedure-or-symbol? x)
  (or (procedure? x) (block? x) (symbol? x)))

;; Get the function corresponding to a branch.
;; The argument can be a procedure?, a branch?,
;; or a symbol which should evaluate to a procedure or branch
(define (get-branch-function context branch)
  (cond ((get-function branch))
        ((bst-function/bstname context branch) => get-function)
        (else #f)))

;; BTX-IF* : stack? integer? procedure? procedure? -> stack?
;; The btxhak documentation says that if$ pops two function literals
;; from the stack, but in a side-remark at the end of the section, it
;; says that an argument "may, for example, be a field name".
;; So we do the same thing.
(define (btx-if* context call-stack stack test true-branch false-branch)
  ;(eprintf "btx-if*: ~s  ~s  ~s~%" false-branch true-branch test)
  (define (evaluate-branch branch)
    (cond ((get-branch-function context branch)
           => (lambda (f)
                (f context stack call-stack)))
          ((bst-variable-get context branch) ;a non-function variable reference
           => (lambda (x) (cons x stack)))
          (else
           (beastie-error/call-stack call-stack
                                     "if$ attempting to push unrecognised symbol ~s" branch))))
  (if (> test 0)
      (evaluate-branch true-branch)
      (evaluate-branch false-branch)))
(define (btx-if context stack call-stack)
  (btx-if* context
           call-stack
           (get-from-stack* 'if$
                            stack
                            call-stack
                            (list procedure-or-symbol? procedure-or-symbol? integer?))))
(btx-function-list* 'if$ btx-if)

;; BTX-WHILE* : stack procedure? procedure? ->
;; Note that the test is always executed at least once.
(define (btx-while* context call-stack initial-stack test-procedure body-procedure)
  #;(eprintf "btx-while*: call-stack=~s  stack=~s  test=~s  body=~s~%"
           call-stack initial-stack test-procedure body-procedure)
  (debug "btx-while*:~%  call-stack=~s~%  stack=~s~%  test=~s~%  body=~s"
         call-stack initial-stack test-procedure body-procedure)
  (let ((test-f (or (get-branch-function context test-procedure)
                    (beastie-error/call-stack call-stack
                                              "unexpected item as while$ test: ~s" test-procedure)))
        (test-lineno (and (block? test-procedure)
                          (block-lineno test-procedure)))
        (body-f (or (get-branch-function context body-procedure)
                    (beastie-error/call-stack call-stack
                                              "unexpected item as while$ body: ~s" body-procedure)))
        (body-lineno (and (block? body-procedure)
                          (block-lineno body-procedure))))
    #;(eprintf "while$:~%  test-f=~a~%    ~s~%  body-f=~a~%"
             test-procedure
             (procedure-source test-f)
             body-procedure)
    (let loop ((s (test-f context
                          initial-stack
                          (cons `(while/test . ,test-lineno) call-stack))))
      #;(eprintf "(test-f ~s) -> ~s~%" initial-stack s)
      (cond ((null? s)
             (beastie-error/call-stack call-stack "while$: test produced empty stack"))
            ((not (integer? (car s)))
             (beastie-error/call-stack call-stack "while$: test produced non-integer top: ~s" s))
            ((> (car s) 0)
             ;; There's a bit of a heisenbug here.  The following
             ;; should be equivalent to
             ;;
             ;; (loop (test-f context
             ;;       (body-f context (cdr s) (cons `(while/body . ,body-lineno) call-stack))
             ;;       (cons `(while/test . ,test-lineno) call-stack)))
             ;;
             ;; but it isn't: the above, when processing the n.dashify
             ;; function in tugboat.bst, with argument "1--2" but not
             ;; with "1-2", weirdly leaps from the outer while$ to the
             ;; test for the inner one.  I have no idea why, and I've
             ;; little idea where I'd start to reduce the issue.
             (let ((body-result (body-f context
                                        (cdr s)
                                        (cons `(while/body . ,body-lineno) call-stack))))
               (loop (test-f context
                             body-result
                             (cons `(while/test . ,test-lineno) call-stack)))))
            (else
             (debug "btx-while*: end -> ~s~%" (cdr s))
             (cdr s))))))
(define (btx-while context stack call-stack)
  (btx-while* context
              call-stack
              (get-from-stack* 'while$
                               stack
                               call-stack
                               (list procedure-or-symbol? procedure-or-symbol?))))
(btx-function-list* 'while$ btx-while)

;; FIXME: The implementation of these next two is incomplete.
;; btxhak says of newline:
;;
;;    Writes onto the bbl file what’s accumulated in the output
;;    buffer. It writes a blank line if and only if the output buffer
;;    is empty. Since write$ does reasonable line breaking, you should
;;    use this function only when you want a blank line or an explicit
;;    line break.
;;
;; We don't currently do the blank-line business, but send the output verbatim.
(bst-wrap-function/stack newline$
                         (λ (context)
                           (newline (or (caar *btx+printf-port-stack*)
                                        (current-output-port)))
                           '()))
(bst-wrap-function/stack write$
                         (λ (context s)
                           (display s (or (caar *btx+printf-port-stack*)
                                          (current-output-port)))
                           '())
                         ustring?)

;; miscellaneous ones
(bst-wrap-function/stack preamble$ (lambda (context) (get-preamble)))

;; btxhak:
;;
;;   purify$ Pops the top (string) literal, removes nonalphanumeric
;;   characters except for white-space characters and hyphens and
;;   ties (these all get converted to a space), removes certain
;;   alphabetic characters contained in the control sequences
;;   associated with a "special character", and pushes the resulting
;;   string.
;;
;; FIXME: We currently skip the 'special character' thing.
(bst-wrap-function/stack purify$
                         (λ (context input)
                           (let ((result (make-ustring))
                                 (i (make-iterator input)))
                             (let loop ()
                               (let ((i0 (i)))
                                 (cond ((eof-object? i0) result)
                                       ((or (uchar-alphabetic? i0)
                                            (char-digit? i0)
                                            (eqv? i0 #x7e) ;tilde
                                            (eqv? i0 #x2d)) ;hyphen
                                        (ustring-append! result i0)
                                        (loop))
                                       (else
                                        (ustring-append! result 32) ;space
                                        (loop)))))))
                         ustring?)

(define (btx-substring* context str start len)
  (let ((strlen (ustring-length str)))
    (cond ;; ((not (and (integer? start) (integer? len)))
          ;;  ;; type error -- see note about the general case in get-from-stack* above
          ;;  ;; No: don't do this unless I need to for some reason.
          ;;  (print-warning
          ;;   "substring$: start and len must be integers, not start=~s and end=~s"
          ;;   start len)
          ;;  #"")
          ((= start 0)
           (beastie-error 'bst "substring$ start cannot be 0"))
          ((or (> start strlen)         ;this isn't an error
               (> (- start) strlen))
           #"")
          ((> start 0)
           (if (> (+ start len) strlen) ;end beyond end of string
               (ustring-substring str (- start 1) strlen)
               (ustring-substring str (- start 1) (+ start -1 len))))
          (else
           (if (< (+ strlen start (- len)) 1) ;start before start of string
               (ustring-substring str 0 (+ strlen start 1))
               (ustring-substring str (+ strlen start (- len) 1) (+ strlen start 1)))))))
(bst-wrap-function/stack substring$ btx-substring* integer? integer? ustring?)

;; FIXME: btxhak's text.prefix$ is more complicated than this, but to implement
;; it I'll have to have more of a think about special characters.
(bst-wrap-function/stack text.prefix$
                         (lambda (context str len)
                           (let ((strlen (ustring-length str)))
                             (ustring-substring str 0 (if (> len strlen) strlen len))))
                         integer? ustring?)

;; ...and similarly for text.length$
(bst-wrap-function/stack text.length$
                         (lambda (context str)
                           (ustring-length str))
                         ustring?)

;; FIXME: I have no idea what to do with this one!
;; I've never been clear what this function actually does, and the
;; btxhak document doesn't really illuminate.
(bst-wrap-function/stack width$
                         (lambda (context s)
                           (* (ustring-length s) 100))
                         ustring?)

(define (stack-value? x)
  (or (integer? x)
      (ustring? x)
      ;; procedure? generally _won't_ appear on the stack, other than
      ;; when if$ or while$ temporarily puts it there
      (procedure? x)
      (block? x)
      (eqv? #<undefined> x)))

;; A 'block' is the body of a function, or a literal {...} in a .bst file.
;; A block is a list of numbers, strings, symbols, quoted-symbols, and blocks
(define (btx-execute-block* context block stack call-stack)
  (let loop ((b block)
             (s stack))
    (if (null? b)
        s
        (let ((next (car b))
              (block-rest (cdr b)))
          (debug "execute-block:~%  block=~s~%  stack=~s~%  call-stack=~s"
                 ;;adding context doesn't help much
                 b s call-stack)
          ;;(debug "...next=~s  block-rest=~s" next block-rest)
          (cond ((or (number? next)
                     (ustring? next)
                     (block? next))
                 (loop block-rest (cons next s)))
                ((symbol? next)
                 ;; Look up this symbol in the current-entry and
                 ;; global tables.  It doesn't matter what order we do
                 ;; these in, since they should be disjoint.
                 (cond ((bst-variable-get context next) ;includes function lookup
                        ;; retrieve field or local value:
                        ;; if this is known but unset, this returns #<undefined>;
                        ;; if the value isn't known, it returns #f
                        => (lambda (v)
                             (cond ((get-function v)
                                    => (λ (f)
                                         (loop block-rest (f context s call-stack))))
                                   (else
                                    (loop block-rest (cons v s))))))
                       (else
                        (beastie-error/call-stack call-stack 'bst
                                                  "attempt to retrieve undefined global '~s'" next))))
                ;; I don't think this next case can happen in fact
                ;; ((procedure? next)      ;ie, a {block}
                ;;  (loop block-rest (next s)))
                ((and (pair? next) (eqv? (car next) '#_quote))
                 (loop block-rest (cons (cadr next) s)))
                (else (beastie-error/call-stack call-stack
                                                "Unimplemented item on stack: ~s" next)))))))

;; The function returned by make-variable-typer is
;; (symbol? #f -> (or/c procedure? 'readonly))
;; or (symbol? (or/c procedure? 'readonly) -> arg2)
;; In the second case, this 'declares' the variable and associates
;; with it a predicate which values assigned to it must satisfy, or
;; else the symbol 'readonly, indicating that it cannot be assigned.
;; In the first case, we retrieve this predicate.
(define (make-variable-typer)
  (let ((*types* (make-hash-table 8 eqv?)))
    (lambda (variable-name type?)
      (if (not type?)
          (*types* variable-name)       ;retrieve
          (cond ((*types* variable-name)
                 => (λ (prev-type)
                      (print-warning "variable '~s' already declared as type ~s, not redeclaring as ~s"
                                     variable-name prev-type type?)))
                ((or (eqv? type? 'readonly)
                     (procedure? type?))
                 (hash-table-set! *types* variable-name type?))
                (else
                 (beastie-error 'bst "unexpected type to variable typer: ~s" type?)))))))

;; The 'context' is the set of global functions and variables (and
;; potentially other stuff in future), which is global to a particular .bst program.
;; Global variables and functions share a common namespace.
(define (make-context)
  (let ((global-variables (make-hash-table 8 eqv?))
        (settable (make-variable-typer))
        (local-variables (make-variable-typer)))

    (define (global-variable-get k)
      (global-variables k))
    #;(define (global-variable-get k)
      (let ((res (global-variable-get* k)))
        (eprintf "global-variable-get: ~s -> ~s~%" k res)
        res))
    (define (global-variable-set! k v)
      ;(eprintf "global-variable-set!: ~s -> ~s~%" k v)
      (cond ((settable k #f)
             => (λ (pred?)
                  (if (pred? v)
                      (hash-table-set! global-variables k v)
                      (beastie-error 'bst
                                     "tried to set variable ~s to value ~s" k v))))
            (else #f)))
    (define (global-variable-set-type! k pred?)
      (if (local-variables k #f)
          (beastie-error 'bst
                         "set-type!: variable ~s is an entry variable of type ~s -- can't be used as a global variable" k (local-variables k #f))
          (begin
            (settable k pred?)
            ;; BibTeX gives global values a default value as soon as they're declared
            (cond ((eqv? pred? ustring?) (hash-table-set! global-variables k #""))
                  ((eqv? pred? integer?) (hash-table-set! global-variables k 0))
                  (else (beastie-error 'bst "unexpected type ~s to for global variable ~s" pred? k))))))
    (define (function-set! name f)
      (cond ((global-variables name)
             (beastie-error 'bst "can't replace function ~s" name))
            ((local-variables name #f)
             => (λ (pred)
                  (beastie-error 'bst
                                 "can't define function ~s; it already exists as an entry variable of type ~s"
                                 name pred)))
            ((or (procedure? f)
                 (block? f))
             (hash-table-set! global-variables name f))
            (else
             (beastie-error 'bst "can't set function ~s to non-procedure ~s" name f))))

    ;; now initialise the context/globals
    ;; (cf btxhak Sect.5.3)
    (hash-table-set! global-variables 'entry.max$ (*s7* 'max-heap-size)) ;arbitrary!
    (hash-table-set! global-variables 'global.max$ (*s7* 'max-string-length))
    (local-variables 'sort.key$ ustring?)
    (local-variables 'crossref ustring?)
    (for-each (λ (p)
                (function-set! (car p) (cdr p)))
              (btx-function-list*))

    (inlet 'global-variable-get global-variable-get
           'global-variable-set! global-variable-set!
           'global-variable-set-type! global-variable-set-type!
           'function-set! function-set!
           ;; the exposed local-variable-get-type is a single-argument function
           'local-variable-get-type (λ (v) (local-variables v #f))
           'local-variable-set-type! local-variables)))

;; Get and set variables in the 'global' namespace represented by the
;; let? passed around these functions, and created within run-bst-program.
(define (bst-variable-get/global context k)
  (or ((context 'global-variable-get) k)
      (global-string-get* k)))
(define (bst-variable-set/global! context k v)
  ((context 'global-variable-set!) k v))

;; BST-FUNCTION/BSTNAME : let? symbol? -> (or/c procedure? block? #f)
;; Look up a function in the global map.
;; Return #f if it's not defined (eg, call.type$ depends on failing to
;; find the function, without error), so don't raise an exception
;; (hmm: change this to catching the error?).
;; If we find something that isn't a function, something may or may
;; not have gone wrong, but we return #f in this case.
(define (bst-function/bstname context fn)
  (and context
       (let ((f ((context 'global-variable-get) fn)))
         (and (or (procedure? f) (block? f)) f))))

(define (run-bst-program bstscm read-bibtex-data)
  ;; bstscm is a parse-tree version of a .bst command;
  ;; read-bibtex-data is a thunk which will read the .bib data and
  ;; return it as a list of entries
  (let ((bibdata '()))
    (define context (make-context))
    (varlet (curlet) context)

    (define (bst-function/bstname fn)   ;shadows same-name function outside
      (let ((f (global-variable-get fn)))
        (and (or (procedure? f) (block? f)) f)))

  ;; For each item in the bstscm list, return a function to be
  ;; appended to the program, or #f if there is nothing to add,
  ;; and we intend only side-effects.
  ;;
  ;; Each of the items in the resulting program must be a function
  ;; (list-of-entries -> list-of-entries).
  ;;
  ;; Several of the macros below accept line-number arguments,
  ;; but don't (yet?) use them.
  (define-macro (comment . body)
    #f)
  (define-macro* (func function-name (line-number #f))
    `(or (bst-function/bstname (#_quote ,function-name))
         (beastie-error 'bst
                        "unrecognised function ~s (line ~a_" (#_quote ,function-name) ,line-numbe)))

  (define-macro (entry fields integers strings)
    `(begin
       (for-each (lambda (k) (local-variable-set-type! k 'readonly))
                 (#_quote ,fields))
       (for-each (lambda (k) (local-variable-set-type! k integer?))
                 (#_quote ,integers))
       (for-each (lambda (k) (local-variable-set-type! k ustring?))
                 (#_quote ,strings))
       #f))

  (define-macro* (execute fn (line-number #f))
    ;; Execute the function f, for side-effects, and return the input entrylist.
    ;; Looking up the function name, fn, when this new procedure is
    ;; called means that we can execute a function which hasn't been
    ;; defined at this point, even though original BibTeX can't do that.
    `(lambda (entrylist)
       (cond ((get-function (bst-function/bstname (#_quote ,fn)))
              => (λ (f)
                   (f context '() (list (cons 'execute ,line-number)))))
             (else
              (beastie-error 'bst "non-function ~s as argument to EXECUTE (line ~a)" ,fn ,line-number)))
       entrylist))

  (define-macro* (block body (line-number #f))
    ;; Recursively expand (block ...) forms
    ;; (NOTE: there's an eval in here -- we are assuming at this point
    ;; that this 'program' comes from a trusted source, so that
    ;; recursively expanding the contents of this macro is OK).
    ;; FIXME: maybe use macroexpand?
    `(btx-make-block* (map (lambda (b)
                             (if (and (list? b) (eqv? (car b) 'block))
                                 (eval b)
                                 b))
                           (#_quote ,body))
                      line-number: ,line-number))

  (define-macro* (function name body (line-number #f))
    ;; 'body' is a (btx-make-block* ...) form
    `(begin
       (function-set! (#_quote ,name) (block-set-name! ,body (#_quote ,name)))
       #f))

  (define-macro (integers variable-names)
    `(begin
       (for-each (lambda (k)
                   (global-variable-set-type! k integer?))
                 (#_quote ,variable-names))
       #f))

  (define-macro* (iterate function-name (line-number #f))
    ;; Call a function for each entry in the entrylist argument, for
    ;; side-effects, and return the entrylist.  Within the context
    ;; which is applied to the function, we include a variable *entry*
    ;; which evaluates to the 'current entry'.
    `(let ((f (or (get-function (bst-function/bstname (#_quote ,function-name)))
                  (beastie-error
                   'bst
                   "iterate: bst-function/bstname called for ~s, which isn't a function (line ~a)"
                   (#_quote ,function-name) ,line-number))))
       (λ (entrylist)
         (for-each (λ (e)
                     (f (inlet context '*entry* e)
                        '()
                        (list (cons 'iterate ,line-number))))
                   entrylist)
         entrylist)))

  (define-macro (macro symbol string)
    `(begin
       (bib-string-table-set! (symbol->ustring (quote ,symbol)) (make-ustring ,string))
       #f))

  (define-macro* (read (line-number #f))
    ;; read the bibliography data from .bib, and store it in bibdata, above
    `(begin
       (set! bibdata (read-bibtex-data))
       #f))

  ;; REVERSE is identical to ITERATE, but processes its argument in
  ;; the opposite order.
  (define-macro* (reverse function-name (line-number #f))
    `(let ((f (or (get-function (bst-function/bstname (#_quote ,function-name)))
                  (beastie-error
                   'bst
                   "reverse: bst-function/bstname called for ~s, which isn't a function (line ~a)"
                   (#_quote ,function-name) ,line-number))))
       (lambda (entrylist)
         (for-each (lambda (e)
                     (f (inlet context '*entry* e) '() (list (cons 'reverse ,line-number))))
                   (with-let (unlet) (reverse entrylist)))
         entrylist)))

  (define-macro* (sort (line-number #f))
    `(λ (entrylist)
       (sort! entrylist
              (λ (a b)
                (let ((ka (or (entry-get-local-variable a 'sort.key$)
                              (symbol->ustring (entry-key a))))
                      (kb (or (entry-get-local-variable b 'sort.key$)
                              (symbol->ustring (entry-key b)))))
                  (ustring<? ka kb))))
       entrylist))

  (define-macro (strings variable-names)
    `(begin
       (for-each (lambda (k)
                   (global-variable-set-type! k ustring?))
                 (#_quote ,variable-names))
       #f))

  (if (list? bstscm)
      (let ((compiled
             (filter values (map eval bstscm))))
        (fold (λ (f entries)
                (f entries))
              bibdata
              compiled))
      (beastie-error 'bst "run-bst-program: given program ~s, expected list" bstscm))))

;; ASSEMBLE-ENTRIES/CITATION* : (listof symbol?) (symbol? -> entry?) -> (hash-table symbol? entry?)
;; Given a list of citation keys, assemble the hash-table of entries which
;; we are to process, taking account of crossrefs.
;;
;; If there are no crossrefs in the initially-cited entries (which is
;; the most common case), then this would be equivalent to
;; (map KEY->ENTRY CITATIONS)
;;
;; For each entry which has a crossref, however, follow the list of
;; crossrefs, and add those to the output list if they appear two or
;; more times in the list of citations.
;;
;; XXX update docs below!
;; We rely on the ENTRY-CROSSREF
;; function to get the crossrefs, so we rely on
;; MAKE-BIBENTRY-ACCUMULATOR* resolving this as required (this
;; currently doesn't support backward references, and is therefore
;; unaffected by circular references).  This also means we don't have
;; to worry about missing cross references (because the accumulator
;; has already done that).
(define (assemble-entries/citation* citations key->entry)
  (let ((seen-crossrefs (make-hash-table 8 eqv?))
        (entries (make-hash-table 8 eqv?)))
    (for-each
     (λ (c)
       (let ((e (key->entry c)))
         (cond ((not e)
                (print-warning "citation key ~s not present in database" c))
               ((entries c))            ;nothing to do
               (else
                (hash-table-set! entries c e) ;add this to the list of entries
                (let loop ((xr-e e))
                  ;; we'll typically go round this look zero or one times,
                  ;; but we here permit a longer chain of crossrefs
                  (let ((next-xr (entry-crossref xr-e)))
                    (when next-xr
                      (let* ((next-key (entry-key next-xr))
                             (seen (seen-crossrefs next-key)))
                        (cond ((not seen)
                               ;; now seen once
                               (hash-table-set! seen-crossrefs next-key 'seen-once))
                              ((eqv? seen 'seen-once)
                               ;; now seen exactly twice
                               (hash-table-set! seen-crossrefs next-key 'seen-twice)
                               ;; ...so add it
                               (hash-table-set! entries next-key next-xr)))
                        (loop next-xr)))))))))
     citations)
    entries))

;; PROCESS-BIBS/BST : (listof string?) (listof string?) string? -> ???
;; Process aux-file contents.
;;
;; CITATIONS is a list of citations, as symbols, or the symbol 'all.
;;
;; BIBDATA-FILES is a list of .bib files to be searched.  Each of
;; these is looked up in the usual TeX search path, both without then
;; with a .bib file extension.
;;
;; BIBSTYLE-FILE is the .bst file to be used.  This, also, is looked
;; up both without and with the .bst file extension.
;;
;; As an undocumented special case, to support testing, if the
;; bibstyle-file starts with "!", the string following it is taken to
;; be a literal .bst program.
(define/provide (process-bibs/bst citations bibdata-files bibstyle-file)
  #"""`process-bibs/bst : (or (listof symbol) 'all) (listof string?) string? -> unspecified` :
In `(process-bibs/bst citation-list bibdata-files bibstyle-file)`, the
`citation-list` is a list of string citations, or the symbol `'all`.

`bibdata-files` is a list of `.bib` files to be searched.  Each of
these is looked up in the usual TeX search path, both without then
with a .bib file extension.

`bibstyle-file` is the .bst file to be used.  This, also, is looked
up both without and with the .bst file extension.
"""
;; Sophistications to come:
;;   let the bibstyle be a .scm file if it exists... somewhere
  (let ((bibdata-files*
         (filter values
                 (map (lambda (f)
                        (resolve-file f ".bib"))
                      bibdata-files)))
        (bibstyle-file*
         (if (char=? (string-ref bibstyle-file 0) #\!)
             #f                         ;special case
             (resolve-file bibstyle-file ".bst"))))
    ;; bibdata-files* and bibstyle-file* are at this point guaranteed
    ;; to be existing files (other than in the special case)

    (let ((read-bibtex-files
           (λ ()
             ;; -> (listof entry?)
             (let ((bibdata
                    (apply append                ;s7 lets you append hash-tables
                           (map parse-bibtex-file bibdata-files*))))
               (map cdr
                    (if (eqv? citations 'all)
                        bibdata
                        (assemble-entries/citation* citations bibdata))))))
          (bibstyle
           (cond ((not bibstyle-file*)  ;special case
                  (parse-bst-string (substring bibstyle-file 1)))
                 ((parse-bst-file bibstyle-file*))
                 (else
                  (beastie-error 'bst "unable to parse ~a as a .bst file" bibstyle-file*)))))
      (run-bst-program bibstyle
                       read-bibtex-files))))