;;;; -*- Scheme -*-

;;;
;;; Syntax Extensions for FTL (Function Template Library) -- esl
;;;


;;;	Marc Feeley's Earley parser is used to parse FTL names as CFG;
;;; the only modifications made to it are ftl: prefixes for visible
;;; names.

; File: "earley.scm"   (c) 1990, Marc Feeley

; Earley parser.

; (make-parser grammar lexer) is used to create a parser from the grammar
; description `grammar' and the lexer function `lexer'.
;
; A grammar is a list of definitions.  Each definition defines a non-terminal
; by a set of rules.  Thus a definition has the form: (nt rule1 rule2...).
; A given non-terminal can only be defined once.  The first non-terminal
; defined is the grammar's goal.  Each rule is a possibly empty list of
; non-terminals.  Thus a rule has the form: (nt1 nt2...).  A non-terminal
; can be any scheme value.  Note that all grammar symbols are treated as
; non-terminals.  This is fine though because the lexer will be outputing
; non-terminals.
;
; The lexer defines what a token is and the mapping between tokens and
; the grammar's non-terminals.  It is a function of one argument, the input,
; that returns the list of tokens corresponding to the input.  Each token is
; represented by a list.  The first element is some `user-defined' information
; associated with the token and the rest represents the token's class(es) (as a
; list of non-terminals that this token corresponds to).
;
; The result of `make-parser' is a function that parses the single input it
; is given into the grammar's goal.  The result is a `parse' which can be
; manipulated with the procedures: `parse->parsed?', `parse->trees'
; and `parse->nb-trees' (see below).
;
; Let's assume that we want a parser for the grammar
;
;  S -> x = E
;  E -> E + E | V
;  V -> V y |
;
; and that the input to the parser is a string of characters.  Also, assume we
; would like to map the characters `x', `y', `+' and `=' into the corresponding
; non-terminals in the grammar.  Such a parser could be created with
;
; (make-parser
;   '(
;      (s (x = e))
;      (e (e + e) (v))
;      (v (v y) ())
;    )
;   (lambda (str)
;     (map (lambda (char)
;            (list char ; user-info = the character itself
;                  (case char
;                    ((#\x) 'x)
;                    ((#\y) 'y)
;                    ((#\+) '+)
;                    ((#\=) '=)
;                    (else (error "lexer error")))))
;          (string->list str)))
; )
;
; An alternative definition (that does not check for lexical errors) is
;
; (make-parser
;   '(
;      (s (#\x #\= e))
;      (e (e #\+ e) (v))
;      (v (v #\y) ())
;    )
;   (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
; )
;
; To help with the rest of the discussion, here are a few definitions:
;
; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
; It indicates a point between two input tokens (0 = beginning, `n' = end).
; For example, if `n' = 4, there are 5 input pointers:
;
;   input                   token1     token2     token3     token4
;   input pointers       0          1          2          3          4
;
; A configuration indicates the extent to which a given rule is parsed (this
; is the common `dot notation').  For simplicity, a configuration is
; represented as an integer, with successive configurations in the same
; rule associated with successive integers.  It is assumed that the grammar
; has been extended with rules to aid scanning.  These rules are of the
; form `nt ->', and there is one such rule for every non-terminal.  Note
; that these rules are special because they only apply when the corresponding
; non-terminal is returned by the lexer.
;
; A configuration set is a configuration grouped with the set of input pointers
; representing where the head non-terminal of the configuration was predicted.
;
; Here are the rules and configurations for the grammar given above:
;
;  S -> .         \
;       0          |
;  x -> .          |
;       1          |
;  = -> .          |
;       2          |
;  E -> .          |
;       3           > special rules (for scanning)
;  + -> .          |
;       4          |
;  V -> .          |
;       5          |
;  y -> .          |
;       6         /
;  S -> .  x  .  =  .  E  .
;       7     8     9     10
;  E -> .  E  .  +  .  E  .
;       11    12    13    14
;  E -> .  V  .
;       15    16
;  V -> .  V  .  y  .
;       17    18    19
;  V -> .
;       20
;
; Starters of the non-terminal `nt' are configurations that are leftmost
; in a non-special rule for `nt'.  Enders of the non-terminal `nt' are
; configurations that are rightmost in any rule for `nt'.  Predictors of the
; non-terminal `nt' are configurations that are directly to the left of `nt'
; in any rule.
;
; For the grammar given above,
;
;   Starters of V   = (17 20)
;   Enders of V     = (5 19 20)
;   Predictors of V = (15 17)

(define (ftl:make-parser grammar lexer)

  (define (non-terminals grammar) ; return vector of non-terminals in grammar

    (define (add-nt nt nts)
      (if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests

    (let def-loop ((defs grammar) (nts '()))
      (if (pair? defs)
        (let* ((def (car defs))
               (head (car def)))
          (let rule-loop ((rules (cdr def))
                          (nts (add-nt head nts)))
            (if (pair? rules)
              (let ((rule (car rules)))
                (let loop ((l rule) (nts nts))
                  (if (pair? l)
                    (let ((nt (car l)))
                      (loop (cdr l) (add-nt nt nts)))
                    (rule-loop (cdr rules) nts))))
              (def-loop (cdr defs) nts))))
        (list->vector (reverse nts))))) ; goal non-terminal must be at index 0

  (define (index nt nts) ; return index of non-terminal `nt' in `nts'
    (let loop ((i (- (vector-length nts) 1)))
      (if (>= i 0)
        (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
        #f)))

  (define (nb-configurations grammar) ; return nb of configurations in grammar
    (let def-loop ((defs grammar) (nb-confs 0))
      (if (pair? defs)
        (let ((def (car defs)))
          (let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
            (if (pair? rules)
              (let ((rule (car rules)))
                (let loop ((l rule) (nb-confs nb-confs))
                  (if (pair? l)
                    (loop (cdr l) (+ nb-confs 1))
                    (rule-loop (cdr rules) (+ nb-confs 1)))))
              (def-loop (cdr defs) nb-confs))))
      nb-confs)))

; First, associate a numeric identifier to every non-terminal in the
; grammar (with the goal non-terminal associated with 0).
;
; So, for the grammar given above we get:
;
; s -> 0   x -> 1   = -> 4   e ->3    + -> 4   v -> 5   y -> 6

  (let* ((nts (non-terminals grammar))          ; id map = list of non-terms
         (nb-nts (vector-length nts))           ; the number of non-terms
         (nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
         (starters (make-vector nb-nts '()))    ; starters for every non-term
         (enders (make-vector nb-nts '()))      ; enders for every non-term
         (predictors (make-vector nb-nts '()))  ; predictors for every non-term
         (steps (make-vector nb-confs #f))      ; what to do in a given conf
         (names (make-vector nb-confs #f)))     ; name of rules

    (define (setup-tables grammar nts starters enders predictors steps names)

      (define (add-conf conf nt nts class)
        (let ((i (index nt nts)))
          (vector-set! class i (cons conf (vector-ref class i)))))

      (let ((nb-nts (vector-length nts)))

        (let nt-loop ((i (- nb-nts 1)))
          (if (>= i 0)
            (begin
              (vector-set! steps i (- i nb-nts))
              (vector-set! names i (list (vector-ref nts i) 0))
              (vector-set! enders i (list i))
              (nt-loop (- i 1)))))

        (let def-loop ((defs grammar) (conf (vector-length nts)))
          (if (pair? defs)
            (let* ((def (car defs))
                   (head (car def)))
              (let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
                (if (pair? rules)
                  (let ((rule (car rules)))
                    (vector-set! names conf (list head rule-num))
                    (add-conf conf head nts starters)
                    (let loop ((l rule) (conf conf))
                      (if (pair? l)
                        (let ((nt (car l)))
                          (vector-set! steps conf (index nt nts))
                          (add-conf conf nt nts predictors)
                          (loop (cdr l) (+ conf 1)))
                        (begin
                          (vector-set! steps conf (- (index head nts) nb-nts))
                          (add-conf conf head nts enders)
                          (rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
                  (def-loop (cdr defs) conf))))))))

; Now, for each non-terminal, compute the starters, enders and predictors and
; the names and steps tables.

    (setup-tables grammar nts starters enders predictors steps names)

; Build the parser description

    (let ((parser-descr (vector lexer
                                nts
                                starters
                                enders
                                predictors
                                steps
                                names)))
      (lambda (input)

        (define (index nt nts) ; return index of non-terminal `nt' in `nts'
          (let loop ((i (- (vector-length nts) 1)))
            (if (>= i 0)
              (if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
              #f)))

        (define (comp-tok tok nts) ; transform token to parsing format
          (let loop ((l1 (cdr tok)) (l2 '()))
            (if (pair? l1)
              (let ((i (index (car l1) nts)))
                (if i
                  (loop (cdr l1) (cons i l2))
                  (loop (cdr l1) l2)))
              (cons (car tok) (reverse l2)))))

        (define (input->tokens input lexer nts)
          (list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))

        (define (make-states nb-toks nb-confs)
          (let ((states (make-vector (+ nb-toks 1) #f)))
            (let loop ((i nb-toks))
              (if (>= i 0)
                (let ((v (make-vector (+ nb-confs 1) #f)))
                  (vector-set! v 0 -1)
                  (vector-set! states i v)
                  (loop (- i 1)))
                states))))

        (define (conf-set-get state conf)
          (vector-ref state (+ conf 1)))

        (define (conf-set-get* state state-num conf)
          (let ((conf-set (conf-set-get state conf)))
            (if conf-set
              conf-set
              (let ((conf-set (make-vector (+ state-num 6) #f)))
                (vector-set! conf-set 1 -3) ; old elems tail (points to head)
                (vector-set! conf-set 2 -1) ; old elems head
                (vector-set! conf-set 3 -1) ; new elems tail (points to head)
                (vector-set! conf-set 4 -1) ; new elems head
                (vector-set! state (+ conf 1) conf-set)
                conf-set))))

        (define (conf-set-merge-new! conf-set)
          (vector-set! conf-set
            (+ (vector-ref conf-set 1) 5)
            (vector-ref conf-set 4))
          (vector-set! conf-set 1 (vector-ref conf-set 3))
          (vector-set! conf-set 3 -1)
          (vector-set! conf-set 4 -1))

        (define (conf-set-head conf-set)
          (vector-ref conf-set 2))

        (define (conf-set-next conf-set i)
          (vector-ref conf-set (+ i 5)))

        (define (conf-set-member? state conf i)
          (let ((conf-set (vector-ref state (+ conf 1))))
            (if conf-set
              (conf-set-next conf-set i)
              #f)))

        (define (conf-set-adjoin state conf-set conf i)
          (let ((tail (vector-ref conf-set 3))) ; put new element at tail
            (vector-set! conf-set (+ i 5) -1)
            (vector-set! conf-set (+ tail 5) i)
            (vector-set! conf-set 3 i)
            (if (< tail 0)
              (begin
                (vector-set! conf-set 0 (vector-ref state 0))
                (vector-set! state 0 conf)))))

        (define (conf-set-adjoin* states state-num l i)
          (let ((state (vector-ref states state-num)))
            (let loop ((l1 l))
              (if (pair? l1)
                (let* ((conf (car l1))
                       (conf-set (conf-set-get* state state-num conf)))
                  (if (not (conf-set-next conf-set i))
                    (begin
                      (conf-set-adjoin state conf-set conf i)
                      (loop (cdr l1)))
                    (loop (cdr l1))))))))

        (define (conf-set-adjoin** states states* state-num conf i)
          (let ((state (vector-ref states state-num)))
            (if (conf-set-member? state conf i)
              (let* ((state* (vector-ref states* state-num))
                     (conf-set* (conf-set-get* state* state-num conf)))
                (if (not (conf-set-next conf-set* i))
                  (conf-set-adjoin state* conf-set* conf i))
                #t)
              #f)))

        (define (conf-set-union state conf-set conf other-set)
          (let loop ((i (conf-set-head other-set)))
            (if (>= i 0)
              (if (not (conf-set-next conf-set i))
                (begin
                  (conf-set-adjoin state conf-set conf i)
                  (loop (conf-set-next other-set i)))
                (loop (conf-set-next other-set i))))))

        (define (forw states state-num starters enders predictors steps nts)

          (define (predict state state-num conf-set conf nt starters enders)

            ; add configurations which start the non-terminal `nt' to the
            ; right of the dot

            (let loop1 ((l (vector-ref starters nt)))
              (if (pair? l)
                (let* ((starter (car l))
                       (starter-set (conf-set-get* state state-num starter)))
                  (if (not (conf-set-next starter-set state-num))
                    (begin
                      (conf-set-adjoin state starter-set starter state-num)
                      (loop1 (cdr l)))
                    (loop1 (cdr l))))))

            ; check for possible completion of the non-terminal `nt' to the
            ; right of the dot

            (let loop2 ((l (vector-ref enders nt)))
              (if (pair? l)
                (let ((ender (car l)))
                  (if (conf-set-member? state ender state-num)
                    (let* ((next (+ conf 1))
                           (next-set (conf-set-get* state state-num next)))
                      (conf-set-union state next-set next conf-set)
                      (loop2 (cdr l)))
                    (loop2 (cdr l)))))))

          (define (reduce states state state-num conf-set head preds)

            ; a non-terminal is now completed so check for reductions that
            ; are now possible at the configurations `preds'

            (let loop1 ((l preds))
              (if (pair? l)
                (let ((pred (car l)))
                  (let loop2 ((i head))
                    (if (>= i 0)
                      (let ((pred-set (conf-set-get (vector-ref states i) pred)))
                        (if pred-set
                          (let* ((next (+ pred 1))
                                 (next-set (conf-set-get* state state-num next)))
                            (conf-set-union state next-set next pred-set)))
                        (loop2 (conf-set-next conf-set i)))
                      (loop1 (cdr l))))))))

          (let ((state (vector-ref states state-num))
                (nb-nts (vector-length nts)))
            (let loop ()
              (let ((conf (vector-ref state 0)))
                (if (>= conf 0)
                  (let* ((step (vector-ref steps conf))
                         (conf-set (vector-ref state (+ conf 1)))
                         (head (vector-ref conf-set 4)))
                    (vector-set! state 0 (vector-ref conf-set 0))
                    (conf-set-merge-new! conf-set)
                    (if (>= step 0)
                      (predict state state-num conf-set conf step starters enders)
                      (let ((preds (vector-ref predictors (+ step nb-nts))))
                        (reduce states state state-num conf-set head preds)))
                    (loop)))))))

        (define (forward starters enders predictors steps nts toks)
          (let* ((nb-toks (vector-length toks))
                 (nb-confs (vector-length steps))
                 (states (make-states nb-toks nb-confs))
                 (goal-starters (vector-ref starters 0)))
            (conf-set-adjoin* states 0 goal-starters 0) ; predict goal
            (forw states 0 starters enders predictors steps nts)
            (let loop ((i 0))
              (if (< i nb-toks)
                (let ((tok-nts (cdr (vector-ref toks i))))
                  (conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
                  (forw states (+ i 1) starters enders predictors steps nts)
                  (loop (+ i 1)))))
            states))

        (define (produce conf i j enders steps toks states states* nb-nts)
          (let ((prev (- conf 1)))
            (if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
              (let loop1 ((l (vector-ref enders (vector-ref steps prev))))
                (if (pair? l)
                  (let* ((ender (car l))
                         (ender-set (conf-set-get (vector-ref states j)
                                                  ender)))
                    (if ender-set
                      (let loop2 ((k (conf-set-head ender-set)))
                        (if (>= k 0)
                          (begin
                            (and (>= k i)
                                 (conf-set-adjoin** states states* k prev i)
                                 (conf-set-adjoin** states states* j ender k))
                            (loop2 (conf-set-next ender-set k)))
                          (loop1 (cdr l))))
                      (loop1 (cdr l)))))))))

        (define (back states states* state-num enders steps nb-nts toks)
          (let ((state* (vector-ref states* state-num)))
            (let loop1 ()
              (let ((conf (vector-ref state* 0)))
                (if (>= conf 0)
                  (let* ((conf-set (vector-ref state* (+ conf 1)))
                         (head (vector-ref conf-set 4)))
                    (vector-set! state* 0 (vector-ref conf-set 0))
                    (conf-set-merge-new! conf-set)
                    (let loop2 ((i head))
                      (if (>= i 0)
                        (begin
                          (produce conf i state-num enders steps
                                   toks states states* nb-nts)
                          (loop2 (conf-set-next conf-set i)))
                        (loop1)))))))))

        (define (backward states enders steps nts toks)
          (let* ((nb-toks (vector-length toks))
                 (nb-confs (vector-length steps))
                 (nb-nts (vector-length nts))
                 (states* (make-states nb-toks nb-confs))
                 (goal-enders (vector-ref enders 0)))
            (let loop1 ((l goal-enders))
              (if (pair? l)
                (let ((conf (car l)))
                  (conf-set-adjoin** states states* nb-toks conf 0)
                  (loop1 (cdr l)))))
            (let loop2 ((i nb-toks))
              (if (>= i 0)
                (begin
                  (back states states* i enders steps nb-nts toks)
                  (loop2 (- i 1)))))
            states*))

        (define (parsed? nt i j nts enders states)
          (let ((nt* (index nt nts)))
            (if nt*
              (let ((nb-nts (vector-length nts)))
                (let loop ((l (vector-ref enders nt*)))
                  (if (pair? l)
                    (let ((conf (car l)))
                      (if (conf-set-member? (vector-ref states j) conf i)
                        #t
                        (loop (cdr l))))
                    #f)))
              #f)))

        (define (deriv-trees conf i j enders steps names toks states nb-nts)
          (let ((name (vector-ref names conf)))

            (if name ; `conf' is at the start of a rule (either special or not)
              (if (< conf nb-nts)
                (list (list name (car (vector-ref toks i))))
                (list (list name)))

              (let ((prev (- conf 1)))
                (let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
                            (l2 '()))
                  (if (pair? l1)
                    (let* ((ender (car l1))
                           (ender-set (conf-set-get (vector-ref states j)
                                                    ender)))
                      (if ender-set
                        (let loop2 ((k (conf-set-head ender-set)) (l2 l2))
                          (if (>= k 0)
                            (if (and (>= k i)
                                     (conf-set-member? (vector-ref states k)
                                                       prev i))
                              (let ((prev-trees
                                      (deriv-trees prev i k enders steps names
                                                   toks states nb-nts))
                                    (ender-trees
                                      (deriv-trees ender k j enders steps names
                                                   toks states nb-nts)))
                                (let loop3 ((l3 ender-trees) (l2 l2))
                                  (if (pair? l3)
                                    (let ((ender-tree (list (car l3))))
                                      (let loop4 ((l4 prev-trees) (l2 l2))
                                        (if (pair? l4)
                                          (loop4 (cdr l4)
                                                 (cons (append (car l4)
                                                               ender-tree)
                                                       l2))
                                          (loop3 (cdr l3) l2))))
                                    (loop2 (conf-set-next ender-set k) l2))))
                              (loop2 (conf-set-next ender-set k) l2))
                            (loop1 (cdr l1) l2)))
                        (loop1 (cdr l1) l2)))
                    l2))))))

        (define (deriv-trees* nt i j nts enders steps names toks states)
          (let ((nt* (index nt nts)))
            (if nt*
              (let ((nb-nts (vector-length nts)))
                (let loop ((l (vector-ref enders nt*)) (trees '()))
                  (if (pair? l)
                    (let ((conf (car l)))
                      (if (conf-set-member? (vector-ref states j) conf i)
                        (loop (cdr l)
                              (append (deriv-trees conf i j enders steps names
                                                   toks states nb-nts)
                                      trees))
                        (loop (cdr l) trees)))
                    trees)))
              #f)))

        (define (nb-deriv-trees conf i j enders steps toks states nb-nts)
          (let ((prev (- conf 1)))
            (if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
              1
              (let loop1 ((l (vector-ref enders (vector-ref steps prev)))
                          (n 0))
                (if (pair? l)
                  (let* ((ender (car l))
                         (ender-set (conf-set-get (vector-ref states j)
                                                  ender)))
                    (if ender-set
                      (let loop2 ((k (conf-set-head ender-set)) (n n))
                        (if (>= k 0)
                          (if (and (>= k i)
                                   (conf-set-member? (vector-ref states k)
                                                     prev i))
                            (let ((nb-prev-trees
                                    (nb-deriv-trees prev i k enders steps
                                                    toks states nb-nts))
                                  (nb-ender-trees
                                    (nb-deriv-trees ender k j enders steps
                                                    toks states nb-nts)))
                              (loop2 (conf-set-next ender-set k)
                                     (+ n (* nb-prev-trees nb-ender-trees))))
                            (loop2 (conf-set-next ender-set k) n))
                          (loop1 (cdr l) n)))
                      (loop1 (cdr l) n)))
                  n)))))

        (define (nb-deriv-trees* nt i j nts enders steps toks states)
          (let ((nt* (index nt nts)))
            (if nt*
              (let ((nb-nts (vector-length nts)))
                (let loop ((l (vector-ref enders nt*)) (nb-trees 0))
                  (if (pair? l)
                    (let ((conf (car l)))
                      (if (conf-set-member? (vector-ref states j) conf i)
                        (loop (cdr l)
                              (+ (nb-deriv-trees conf i j enders steps
                                                 toks states nb-nts)
                                 nb-trees))
                        (loop (cdr l) nb-trees)))
                    nb-trees)))
              #f)))

        (let* ((lexer      (vector-ref parser-descr 0))
               (nts        (vector-ref parser-descr 1))
               (starters   (vector-ref parser-descr 2))
               (enders     (vector-ref parser-descr 3))
               (predictors (vector-ref parser-descr 4))
               (steps      (vector-ref parser-descr 5))
               (names      (vector-ref parser-descr 6))
               (toks       (input->tokens input lexer nts)))

          (vector nts
                  starters
                  enders
                  predictors
                  steps
                  names
                  toks
                  (backward (forward starters enders predictors steps nts toks)
                            enders steps nts toks)
                  parsed?
                  deriv-trees*
                  nb-deriv-trees*))))))

(define (ftl:parse->parsed? parse nt i j)
  (let* ((nts     (vector-ref parse 0))
         (enders  (vector-ref parse 2))
         (states  (vector-ref parse 7))
         (parsed? (vector-ref parse 8)))
    (parsed? nt i j nts enders states)))

(define (ftl:parse->trees parse nt i j)
  (let* ((nts          (vector-ref parse 0))
         (enders       (vector-ref parse 2))
         (steps        (vector-ref parse 4))
         (names        (vector-ref parse 5))
         (toks         (vector-ref parse 6))
         (states       (vector-ref parse 7))
         (deriv-trees* (vector-ref parse 9)))
    (deriv-trees* nt i j nts enders steps names toks states)))

(define (ftl:parse->nb-trees parse nt i j)
  (let* ((nts             (vector-ref parse 0))
         (enders          (vector-ref parse 2))
         (steps           (vector-ref parse 4))
         (toks            (vector-ref parse 6))
         (states          (vector-ref parse 7))
         (nb-deriv-trees* (vector-ref parse 10)))
    (nb-deriv-trees* nt i j nts enders steps toks states)))


; end of "earley.scm"


;;;	FTL-Syntax

(define (ftl:name->list str wrap-id)
  (define (reduce lst)
    (string->symbol 
      (list->string 
        (map char-downcase 
          (reverse lst)))))
  (define (parse-ftl-name src return stop)
    (define (scan lst src)
      (if (null? src) (stop)
          (let ((c (car src)))
            (cond ((char=? c #\%) ;%name is special
                   (if (and (pair? (cdr src)) (char-alphabetic? (cadr src)))
                       (scan-id lst (cdr src))
                       (return (reduce (cons c lst)) (cdr src))))
                  ((char-numeric? c) (scan-num (cons c lst) (cdr src)))
                  ((char-alphabetic? c) (scan-alpha (cons c lst) (cdr src)))
                  (else (return (reduce (cons c lst)) (cdr src)))))))
    (define (scan-id lst src)
      (if (null? src)
          (return (wrap-id (reduce lst)) src)
          (let ((c (car src)))
            (cond ((char-alphabetic? c) (scan-id (cons c lst) (cdr src)))
                  (else (return (wrap-id (reduce lst)) src))))))
    (define (scan-alpha lst src)
      (if (or (null? src) (equal? lst '(#\b #\u #\s))) 
          (return (reduce lst) src)
          (let ((c (car src)))
            (cond ((char-alphabetic? c) (scan-alpha (cons c lst) (cdr src)))
                  (else (return (reduce lst) src))))))
    (define (scan-num lst src)
      (if (null? src) (return (reduce lst) src)
          (let ((c (car src)))
            (cond ((char-numeric? c) (scan-num (cons c lst) (cdr src)))
                  (else (return (reduce lst) src))))))
    (scan '() src))
  (let loop ((src (string->list str)))
    (parse-ftl-name src ;=> 
      (lambda (tk src) (cons tk (loop src)))
      (lambda () '()))))


(define (ftl:merge! less? lst1 lst2) 
  (cond
    ((null? lst1) lst2)
    ((null? lst2) lst1)
    ((less? (car lst2) (car lst1))
     (set-cdr! lst2 (ftl:merge! less? lst1 (cdr lst2)))
     lst2)
    (else (set-cdr! lst1 (ftl:merge! less? (cdr lst1) lst2)) lst1)))

(define (ftl:split! lst)
  (if (null? lst)
      lst
      (let loop ((hd lst) (tl (cdr lst)))
        (if (or (null? tl) (null? (cdr tl)))
            (let ((x (cdr hd)))
              (set-cdr! hd '())
              x)
            (loop (cdr hd) (cddr tl))))))

(define (ftl:sort! less? lst) 
  (cond
     ((null? lst) '())
     ((null? (cdr lst)) lst)
     (else
      (let ((lst2 (ftl:split! lst)))
        (ftl:merge! less? 
          (ftl:sort! less? lst) 
          (ftl:sort! less? lst2))))))


(define (ftl:syntax-error reason . args)
  (display "Error in FTL-syntax: ")
  (display reason)
  (for-each (lambda (arg) (display " ") (write arg)) args)
  (newline)
  (reset)) ;Chez/SXM's way to get back to REPL


;; The complete list of trivial FTL
;; interfaces (a.k.a. "casts"). These
;; are kept separate because casts are
;; treated specially by ranking pass
;; (casts incur no performance penalty).

(define ftl:*cast-interfaces* '(
  e=%oe
  t=%e
  l=%ml
  ml=%rml
  l=%rl
  rl=%rml
  l=%rml
  v=%mv
))

;; The complete list of nontrivial 
;; FTL interfaces. Position in this list 
;; is used as a crude way to hint at 
;; interface's "quality" (i.e. performance);
;; "better" interfaces should go first.
;; Only minimal attempt has been made to 
;; actually use this feature ...

(define ftl:*interfaces* '(
  e=q
  e=v
  e=l
  oe=number
  oe=char
  oe=char-ci
  t=if
  t=if-not
  t=%oe<
  t=%oe>
  t=%oe>=
  t=%oe<=
  t=not-%t
  x=not
  x=abs
  x=add1
  x=sub1
  x=car
  x=cdr
  x=itoc
  x=ctoi
  x=upcase
  x=downcase
  v=iota
  v=symbol
  mv=vector
  mv=string
  rml=list
  l=char-port
  rl=%v
  rml=%mv
  rl=reverse-%v
  rml=reverse-%mv
  g=iota
  g=list
  g=reverse-list
  g=%v
  g=reverse-%v
  g=port    
  g=char-port
  g=line-port
  g=file
  g=char-file
  g=line-file
  g=%g-%x
  o=count
  o=sum
  o=product
  o=min
  o=max
  o=list
  o=reverse-list
  o=%e-lset
  o=%mv
  o=port
  o=char-port
  o=line-port
  o=file
  o=char-file
  o=line-file
  o=gcd
  o=lcm
  a=%o
  a=and
  a=or
  a=%mv
  a=reverse-%mv
  a=%mv!
  a=reverse-%mv!
  a=%x-%a
  i=%l
  i=port
  i=char-port
  i=line-port
  i=file
  i=char-file
  i=line-file
  e=%i-of-%e
  oe=%i-of-%oe
  oe=string
  oe=string-ci
))    


;; The complete list of FTL algorithms.
;; Position in this list is used as a crude
;; way to hint at algorithm's "quality";
;; "better" algorithm should go first.
;; Only minimal attempt has been made to 
;; actually use this feature ...

(define ftl:*algorithms* '(
  %e=?
  %oe=?
  %oe<?
  %oe>?
  %oe>=?
  %oe<=?
  %oe-min
  %oe-max
  %t?
  %x
  %v-length
  %v-ref
  %v-null?
  %v-fold-left
  %v-fold-right
  %mv-length
  %mv-ref
  %mv-set!
  make-%mv
  sub%mv
  %mv-copy
  %mv-fill!
  %mv-resize
  %v->%mv
  %v->%mv!
  %mv
  list->%mv
  %mv-append
  %mv-reverse!
  %v-sorted?
  %v-%oe-sorted?
  %mv-sort!
  %mv-%oe-sort!
  %mv-stable-sort!
  %mv-stable-%oe-sort!
  %mv-remove-neighbor-dups!
  %mv-remove-neighbor-%e-dups!
  %v-binary-search
  %v-position-%oe/sorted
  t=%rl-%e-member
  t=%rl-%e-members
  t=string-member
  t=string-members
  t=string-ci-member
  t=string-ci-members
  %l-null?
  %l-car
  %l-cdr
  %ml-set-car!
  %l-tail
  %l-ref
  %ml-set!
  %l-member-%t
  %l-drop-%t
  %l-take->%a+tail
  %l-take-%t->%a+tail
  %l-take-map->%a+tail
  %rl-remove-%e-duplicates->%a
  %ml-map!
  %ml-substitute-%t!
  %g-fold
  %g-length
  %g-for-each
  %g-last
  %g-count-%t
  %g-last-%t
  %o-create
  %o-write
  %o-result
  %g->%o
  %g-append->%o
  %g-append->%o*
  %g->%o/%g-splicing
  %g-map1->%o
  %g-map1->%o/%g-splicing
  %g-remove-%t->%o
  %g-partition-%t->%o+%o
  %g-filter-map1->%o
  %g-substitute-%t->%o
  %a-unfold
  %a-tabulate
  %a-iota
  make-%a
  %a
  %a*
  %i-open
  %i-read
  %i-ref
  %i-andmap-%t
  %i-ormap-%t
  %i-andmap
  %i-ormap
  %i-find-%t
  %i-position-%t
  %i-index
  %i-mismatch-%e
  %i-sub%v-position-%e
  %i->%a
  %i-map1->%a
  %i-map->%a
  %i-filter-map1->%a
  %i-filter-map->%a
  %i-head->%a
  sub%i->%a
  %i-take-%t->%a
  %i-take-map1->%a
  %i-take-map->%a
))

(define (ftl:cast? sym)
  (memq sym ftl:*cast-interfaces*)) 

(define (ftl:cast-expr? exp)
  (and (pair? exp) (ftl:cast? (car exp)) (= 2 (length exp))))

(define (ftl:template-position sym)
  (define (posq s l)
	  (let loop ((l l) (n 0))
		  (cond ((null? l) #f)
			      ((eq? (car l) s) n)
						(else (loop (cdr l) (+ n 1))))))
	(or (posq sym ftl:*interfaces*)
	    (posq sym ftl:*algorithms*)))

;; name parsing helpers
(define (ftl:id->cat id)
  (string->symbol 
    (string-append "%" 
      (symbol->string id))))

(define (ftl:id-cat? id)
  (and (symbol? id)
    (char=? #\% 
      (string-ref 
        (symbol->string id) 
        0))))

(define (ftl:id-stem id)
  (string->symbol 
    (list->string 
       (cdr 
         (string->list 
           (symbol->string id))))))

;; assemble grammar productions
(define (ftl:algorithm-grammar)
  (define interfaces-alist '())
  (define algorithms-list '())
  (define (push-assoc! key val alist)
    (let ((p (assq key alist)))
      (if p 
         (set-cdr! p (cons val (cdr p)))
         (set! alist (cons (list key val) alist)))
      alist))
  (define (add-int-rule! sym)
    (let ((pat (ftl:name->list (symbol->string sym) ftl:id->cat)))
      (if (and (>= (length pat) 3)
               (symbol? (car pat))
               (eq? (cadr pat) '=))
          (set! interfaces-alist
				    (push-assoc! (ftl:id->cat (car pat)) (cddr pat) 
              interfaces-alist))
          (ftl:syntax-error 
            "Not a valid identifier name/constructor" sym))))
  (define (add-alg-rule! sym)
    (let ((pat (ftl:name->list (symbol->string sym) ftl:id->cat)))
      (if (>= (length pat) 1)
          (set! algorithms-list
				    (append algorithms-list (list pat)))
          (ftl:syntax-error 
            "Not a valid algorithm name" sym))))
  (for-each add-int-rule! ftl:*cast-interfaces*)
  (for-each add-int-rule! ftl:*interfaces*)
  (for-each add-alg-rule! ftl:*algorithms*)
  (cons (cons '%algorithm% algorithms-list) interfaces-alist))

(define ftl:algorithm-parser 
  (ftl:make-parser
    (ftl:algorithm-grammar)
    (lambda (l) (map (lambda (x) (list x x)) l))))

(define (ftl:parse-algorithm-name sym) 
  (define (err id)
    (ftl:syntax-error 
      "Unexpected % inside algorithm name" sym))
  (let* ((l (ftl:name->list (symbol->string sym) err))
         (t* (ftl:parse->trees (ftl:algorithm-parser l) 
               '%algorithm% 0 (length l))))
    (define (clean-tree t)
      (if (pair? t)
          (cons (caar t) (map clean-tree (cdr t)))
          t))
    (define (pk sl)
      (string->symbol
        (apply string-append
          (map symbol->string sl))))
    (define (t->exp l)
      (let ((exp (cvt l)))
        (if (and (pair? exp) (null? (cdr exp)))
            (car exp)
            exp)))
    (define (cvt l)
      (if (pair? l)
          (cons (pk (map car l))
             (let loop ((l l) (r '()))
                (cond ((null? l) 
                       (reverse r))
                      ((ftl:id-cat? (caar l))
                       (let ((s (ftl:id-stem (caar l))))
                         (loop (cdr l) 
                           (cons 
                              (t->exp (cons (list s s) (cons (list '= '=) (cdar l)))) 
                              r))))
                      (else (loop (cdr l) r)))))
          (box l)))
    (map 
      (lambda (t)
        (t->exp (cdr (clean-tree t)))) 
      t*)))


;; Ad-hoc rule #1: prefer simpler expressions
;; (simplicity is measured by # of conses). 
;; Casts are not counted.

(define (ftl:expr-complexity exp)
  (cond ((not (pair? exp)) 0)
        ((ftl:cast-expr? exp)
         (ftl:expr-complexity (cadr exp)))
        (else
         (+ 1 (ftl:expr-complexity (car exp))
              (ftl:expr-complexity (cdr exp))))))


;; Ad-hoc rule #2: prefer interfaces/algorithms
;; closer to the beginning of the respective list.
;; When used after rule #1, it gives a single
;; "best" choice. Care should be taken to ensure
;; that all choices are functionally equivalent,
;; so that we choose performance, not semantics.
;; Casts are taken into account, but only as 
;; tie-breakers (after everything else).

(define (ftl:expr-compare-cps exp1 exp2 return)
  (cond
    ((ftl:cast-expr? exp1)
     (ftl:expr-compare-cps (cadr exp1) exp2
       (lambda (c) (return (if (zero? c) 1 c)))))
    ((ftl:cast-expr? exp2)
     (ftl:expr-compare-cps exp1 (cadr exp2)
       (lambda (c) (return (if (zero? c) -1 c)))))
    ((and (null? exp1) (null? exp2))
     (return 0))
    ((and (symbol? exp1) (symbol? exp2))
     (return
       (- (ftl:template-position exp1) 
          (ftl:template-position exp2))))
    ((and (symbol? exp1) (pair? exp2))
     (return -1))
    ((and (pair? exp1) (symbol? exp2))
     (return 1))
    ((and (pair? exp1) (pair? exp2))
     (ftl:expr-compare-cps (car exp1) (car exp2)
       (lambda (c)
         (if (zero? c)
             (ftl:expr-compare-cps (cdr exp1) (cdr exp2) return)
             (return c)))))
    (else 
		 (ftl:syntax-error 
      "Unexpected FTL expression" exp1))))

(define (ftl:expr-compare exp1 exp2)
  (ftl:expr-compare-cps exp1 exp2 values))
  

;; debug parameter to make choices visible
(define ftl:verbose
  (let ((verbose #f))
    (lambda ?v
      (if (null? ?v)
          verbose
          (set! verbose (car ?v)))))) 

(define (ftl:choose-best-expr exp*)
  (let ((matches 
         (map (lambda (exp) (cons (ftl:expr-complexity exp) exp)) exp*))
        (verbose? (ftl:verbose)))
    (set! matches 
      (ftl:sort! (lambda (e1 e2) (< (car e1) (car e2))) matches))
    (when verbose?
      (for-each
        (lambda (s&exp)
           (display "Complexity ")
           (display (car s&exp))
           (display ": ")
           (write (cdr s&exp))
           (newline))
        matches)
      (display "No (more) matches.") 
      (newline))
    ;; chose the "best" expression
    (cond 
      ((null? matches)
       #f)
      ((null? (cdr matches))
       (cdar matches))
      (else
       (let ((complexity (caar matches)))
         (let loop ((m* matches) (e* '()))
           (if (and (pair? m*) (= (caar m*) complexity))
               (loop (cdr m*) (cons (cdar m*) e*))
               (begin
                 (set! e* 
                   (ftl:sort! 
                     (lambda (e1 e2) 
                       (< (ftl:expr-compare e1 e2) 0))
                     e*))
                 (when verbose?
								   (display "Lowest complexity, sorted by position (best match is first):")
									 (newline)
                   (for-each (lambda (exp) (write exp) (newline)) e*))
                 (car e*))))))))) 

(define (ftl:algorithm-name->expr sym)
  (ftl:choose-best-expr (ftl:parse-algorithm-name sym)))


;; Syntax-rules-based macros

(define-syntax template-function
  (lambda (x)
    (syntax-case x ()
      ((_ t)
       (let ((sym (syntax-object->datum (syntax t))))
         ;; works in Chez, SXM (expander picks up defines) 
         ;; MsScheme will need module, require-for-syntax
         (let ((exp (ftl:algorithm-name->expr sym)))
				   (if exp
               (with-syntax ((v (datum->syntax-object (syntax t) exp)))
                 (syntax v))
							 (syntax-error (syntax t) 
                 "template-function: cannot parse template"))))))))

(define-syntax template-define
  (lambda (x)
    (syntax-case x ()
      ((_ t)
       (syntax (define t (template-function t))))
      ((_ f t)
       (syntax (define f (template-function t))))
      ((_ (f t)) ;same as above; used by t-d*
       (syntax (define f (template-function t)))))))

(define-syntax template-define*
  (lambda (x)
    (syntax-case x ()
      ((_ t ...)
       (syntax 
         (begin (template-define t) ...))))))

;; -- tests &c --

(define *template-list* '(
  list
  list*
  make-list
  list-tabulate
  list->list
  list-iota
  list-index                      ;*
  list-ref
  list-tail
  list-take->list
  list-tail
  list-take->list+tail
  list-last
  list-length
  list-append->list
  list->list/list-splicing
  list->reverse-list
  list->reverse-list
  list-filter-map->count
  list-fold                       ;1
  reverse-list-fold               ;1
  list-map->list
  list-for-each                   ;1
  list-map1->list/list-splicing   ;1
  list-map->list
  list-filter-map->list
  list-remove-if-not->list
  list-partition-if->list+list
  list-remove-if->list
  list-find-if
  list-member-if
  list-take-if->list
  list-drop-if
  list-take-if->list+tail
  list-take-if-not->list+tail
  list-ormap
  list-andmap
  list-position-if                ;1
  list-member-l                   ;*
  list-member-q
  list-member-v
  list-remove-l->list             ;*
  string-null?
  string-ormap                    ;*
  string-andmap                   ;*
  make-string
  string
  string-tabulate
  string->list
  list->string
  reverse-list->string
  string-length
  string-ref
  string-copy
  substring
  string->string!                 ;r  
  string-take->string
  string-set!
  string-fill!
  string<?
  string<=?
  string>?
  string>=?
  string=?
  string-ci<?
  string-ci<=?
  string-ci>?
  string-ci>=?
  string-ci=?
  string-of-char<?
  string-of-char<=?
  string-of-char>?
  string-of-char>=?
  string-of-char=?
  string-of-char-ci<?
  string-of-char-ci<=?
  string-of-char-ci>?
  string-of-char-ci>=?
  string-of-char-ci=?
  string-mismatch-char            ;*
  string-mismatch-char-ci         ;*
  string-position-if              ;?
  string-position-if-not          ;?
  string-filter-map->count        ;?
  string-upcase->string
  string-downcase->string
  reverse-string->string
  string-reverse!
  string-append
  list->string/string-splicing
  reverse-list->string/string-splicing ;*
  string-map1->string
  string-map!
  string-fold
  reverse-string-fold
  string-for-each
  string->string!                 ;*r
  string-remove-if-not->string    ;?    
  string-remove-if->string        ;?    
  string-sort!
  string-char-sort!
  string-char-ci-sort!
  string-stable-char-ci-sort!
  string-char-ci-sorted?

  vector-null?
  vector
  make-vector
  vector-tabulate
  vector-copy
  vector-resize
  vector-iota
  vector-index                    ;*
  vector-ref
  vector-last
  vector-take->vector
  vector-length
  vector->vector!                 ;r
  vector-copy!  
  vector-append
  vector->vector/vector-splicing
  list->vector/vector-splicing
  vector->reverse-vector
  vector-reverse!
  vector-count-if
  ;; vector-reverse
  vector->reverse-vector
  vector-filter-map->count
  vector-fold                     ;1
  reverse-vector-fold             ;1
  vector-map->vector
  vector-map->vector
  vector-map!
  vector-for-each
  vector-map1->vector/vector-splicing ;1
  vector-filter-map->vector
  vector-remove-if-not->vector
  vector-partition-if->vector+vector
  vector-find-if
  vector-take-if->vector
  vector-ormap
  vector-andmap
  vector-position-if              ;1
  vector-position-if-not          ;1
  vector-remove-if->vector        ;?    
  vector-set!
  vector-fill!
  vector->string
  string->vector
  vector->list
  list->vector
  vector-sort!
  vector-stable-sort!
  vector-sorted?
))

(define (ftl-check sym)
  (let ((exp (ftl:algorithm-name->expr sym)))
    (if exp
      (begin
        (write sym)
        (display " = ")
        (write exp)
        (newline))
      (begin
        (write sym)
        (display " = ?")
        (newline)
        (let ((v (ftl:verbose)))
          (ftl:verbose #t)
          (ftl:algorithm-name->expr sym)
          (ftl:verbose v))
        (newline)))))

;(for-each ftl-check *template-list*)




;; grammar checking tools

(define (ftl:push-assoc! key val alist)
  (let ((p (assq key alist)))
    (if p 
       (set-cdr! p (cons val (cdr p)))
       (set! alist (cons (list key val) alist)))
    alist))

(define (ftl:select p? l) ;aka filter
  (cond ((null? l) '())
        ((p? (car l)) (cons (car l) (ftl:select p? (cdr l))))
        (else (ftl:select p? (cdr l)))))

(define (ftl:accumulate kons knil l) ;aka fold-right
  (let loop ((l l))
    (if (null? l)
        knil
        (kons (car l) (loop (cdr l))))))         

(define (ftl:fold kons knil l)
  (let loop ((l l) (r knil))
    (if (null? l)
        r
        (loop (cdr l) (kons (car l) r))))) 

(define (ftl:adjoinq e s)
  (if (memq e s) s (cons e s)))

(define (ftl:closeq e->s s)
  (let add ((from s) (to '()))
    (ftl:fold
      (lambda (e s)
        (if (memq e s)
            s
            (add (e->s e) (cons e s))))
      to
      from)))

(define (ftl:rev-car lst) ;aka last
  (if (null? (cdr lst)) 
      (car lst) 
      (ftl:rev-car (cdr lst))))

(define ftl:*id-gcats* '()) ;; id -> (id)
(define ftl:*id-plist* '()) ;; id -> rules
(define ftl:*id-lookaheads* '()) ;; id -> lookaheads
(define ftl:*id-lookbehinds* '()) ;; id -> lookbehinds
(define ftl:*id-constituents* '()) ;; id -> constituents

(define (ftl:id->gcat id) ;=> (id), eq-unique
  (let ((gcat (assq id ftl:*id-gcats*)))
    (or gcat
      (let ((gcat (list id)))
        (set! ftl:*id-gcats* (cons gcat ftl:*id-gcats*))
        gcat))))

(define (ftl:id->gcat? id)
  (assq id ftl:*id-gcats*))

(define (ftl:recalc-gcats)
  (for-each 
    (lambda (id&rules)
      (ftl:id->gcat (car id&rules)))
    ftl:*id-plist*))
     
(define (ftl:id-starts-with? id sym)
  (let ((p (assq id ftl:*id-lookaheads*)))
    (and p (memq sym (cdr p)))))

(define (ftl:expand-lookaheads e) ;=> (e ...)
  (if (pair? e) ;gcat
      (cond ((assq (car e) ftl:*id-plist*) =>
             (lambda (id&rules) 
               (ftl:fold ftl:adjoinq '()
                 (map
                   (lambda (rule)
                     (or (ftl:id->gcat? (car rule)) (car rule))) 
                   (cdr id&rules)))))
            (else '()))
      (list e)))

(define (ftl:calc-id-lookaheads id&rules)
  (let* ((gcat (ftl:id->gcat (car id&rules)))
         (la-list (ftl:closeq ftl:expand-lookaheads (list gcat))))
    (cons (car id&rules) 
      (ftl:select symbol? la-list))))

(define (ftl:recalc-lookaheads)
  (set! ftl:*id-lookaheads*
    (map ftl:calc-id-lookaheads ftl:*id-plist*))
  #t)


(define (ftl:id-ends-with? id sym)
  (let ((p (assq id ftl:*id-lookbehinds*)))
    (and p (memq sym (cdr p)))))

(define (ftl:expand-lookbehinds e) ;=> (e ...)
  (if (pair? e) ;gcat
      (cond ((assq (car e) ftl:*id-plist*) =>
             (lambda (id&rules) 
               (ftl:fold ftl:adjoinq '()
                 (map
                   (lambda (rule)
                     (let ((id (ftl:rev-car rule)))
                       (or (ftl:id->gcat? id) id))) 
                   (cdr id&rules)))))
            (else '()))
      (list e)))

(define (ftl:calc-id-lookbehinds id&rules)
  (let* ((gcat (ftl:id->gcat (car id&rules)))
         (lb-list (ftl:closeq ftl:expand-lookbehinds (list gcat))))
    (cons (car id&rules) 
      (ftl:select symbol? lb-list))))

(define (ftl:recalc-lookbehinds)
  (set! ftl:*id-lookbehinds*
    (map ftl:calc-id-lookbehinds ftl:*id-plist*))
  #t)


(define (ftl:expand-constituents e) ;=> (e ...)
  (if (pair? e) ;gcat
      (cond ((assq (car e) ftl:*id-plist*) =>
             (lambda (id&rules) 
               (ftl:fold
                 (lambda (rule set)
                   (ftl:fold
                     (lambda (id set)
                       (ftl:adjoinq 
                         (or (ftl:id->gcat? id) id) set)) 
                     set rule))
                 '()
                 (cdr id&rules))))
            (else '()))
      (list e)))

(define (ftl:calc-id-constituents id&rules)
  (let* ((gcat (ftl:id->gcat (car id&rules)))
         (cn-list (ftl:closeq ftl:expand-constituents (list gcat))))
    (cons (car id&rules) (ftl:select symbol? cn-list))))

(define (ftl:recalc-constituents)
  (set! ftl:*id-constituents*
    (map ftl:calc-id-constituents ftl:*id-plist*))
  #t)

(set! ftl:*id-plist* (ftl:algorithm-grammar))
(ftl:recalc-gcats)
(ftl:recalc-lookaheads)
(ftl:recalc-lookbehinds)
(ftl:recalc-constituents)


#|

x
t < e < oe
a < o < mv
g < i < li < v < mv

(define-syntax foo
  (let ((cnt 0))
    (define (next) (set! cnt (+ 1 cnt)) cnt)
    (lambda (x)
      (syntax-case x ()
        ((foo)
         (with-syntax ((v (datum->syntax-object (syntax foo) (next))))
           (syntax (list v))))))))


(define bar-cnt 0)
(define (next-bar) (set! bar-cnt (+ 1 bar-cnt)) bar-cnt)
(define-syntax bar
  (lambda (x)
    (syntax-case x ()
      ((bar)
       (with-syntax ((v (datum->syntax-object (syntax bar) (next-bar))))
         (syntax (list v)))))))




|#