anchor.diff:  
   (in-package :com.gigamonkeys.yamp)
   
  -;;; TODO:
  -;;;
  -;;; - state manipulation
  -;;;
  -;;; - MOAR gensyms
  -;;;
  -
  -#|
  -
  -* Evaluation rules
  -
  -SYMBOL naming a production or external parser
  -
  -  => `(lambda (text state position) (,SYMBOL text state position))
  -
  -(SYMBOL &rest args) where SYMBOL names a production or an external parser
  -
  -  => `(lambda (text state position) (,SYMBOL ,@args text state position))
  -
  -SYMBOL not naming a production or external parser. This is an error at
  -the top-level of a production except as the last form.
  -
  -  => SYMBOL
  -
  -(SYMBOL &rest args) where SYMBOL does not name a production or an
  -external parser. This is an error at the top-level of a production
  -except as the last form.
  -
  -  => (,SYMBOL ,@args)
  -
  -(MATCH "STRING")
  -
  -  => (string-matcher "STRING")
  -
  -(MATCH #\Character)
  -
  -  => (character-matcher #\Character)
  -
  -(OR ...)
  -
  -  =>
  -
  -
  -(PROGN p), p a parser function
  -
  -  => (lambda (text state position)
  -       (funcall p text state position))
  -
  -(PROGN x), x not a parser function
  -
  -  => (lambda (text state position)
  -       (declare (ignore text))
  -       (values t x state position))
  -
  -
  -(PROGN p1 p2 ... x) where X evaluates to a production or parser
  -
  -  => (lambda (text state position)
  -       (multiple-value-bind (ok r s pos) (funcall ,p1 text state position)
  -         (if ok
  -             (multiple-value-bind (ok r s pos) (funcall ,p2 text s p)
  -               ...
  -               (if ok
  -                   (multiple-value-bind (ok r s pos) (funcall ,x text s p)
  -                     (if ok
  -                         (values t r s p)
  -                         (values nil nil state position))))))))
  -
  -
  -(PROGN p1 p2 ... x) where X does not evaluate to a production or parser
  -
  -  => (lambda (text state position)
  -       (multiple-value-bind (ok r s pos) (funcall ,p1 text state position)
  -         (if ok
  -             (multiple-value-bind (ok r s pos) (funcall ,p2 text s p)
  -               (if ok
  -                   (values t ,x s p)
  -                   (values nil nil state position))))))
  -
  -
  -(-> p SYMBOL)
  -
  -  => (multiple-value-bind (ok SYMBOL s pos) (funcall p text state position)
  -       (if ok
  -           <continuation>
  -            (t (values nil nil state position))))))
  -
  -
  -(STATE SYMBOL)
  -
  -  => (cdr (assoc symbol state))
  -
  -(SETF (STATE SYMBOL) VALUE)
  -
  -  => (setf state (acons symbol value state))
  -
  -Examples:
  -
  -(many (try eol))
  -
  -  => (lambda (text state position)
  -       (many (lambda (text state position)
  -               (try
  -                (lambda (text state position) (eol text state position))))
  -             text
  -             state
  -             position))
  -
  -(many (p foo (-> bar res) baz res))
  -
  -  => (lambda (text state position)
  -        (many (lambda (text state position)
  -                (multiple-value-bind (ok r s pos) (funcall foo text state position)
  -                  (if ok
  -                      (multiple-value-bind (ok res s pos) (funcall bar text state position)
  -                        (if ok
  -                            (multiple-value-bind (ok r s pos) (funcall baz text state position)
  -                              (if ok
  -                                  (values t res s pos)
  -                                  (values nil nil state pos)))
  -                            (values nil nil state pos)))
  -                      (values nil nil state pos))))
  -              text state position))
  -
  -(count 3 " ")
  -
  -  => (lambda (text state position)
  -       (count 3 (lambda (text state position) (match-string " " text state position))))
  -
  -(progn foo bar)
  -
  -  => (lambda (text state position)
  -       (multiple-value-bind (ok x s pos) (funcall foo text state position)
  -         (if ok
  -             (multiple-value-bind (ok r s pos) (funcall bar text state position)
  -               (if ok
  -                   (values t r s pos)
  -                   (values nil nil state position)))
  -             (values nil nil state position))))
  -
  -
  -(progn (-> foo x) `(:whatever x))
  -
  -  => (lambda (text state position)
  -       (multiple-value-bind (ok x s pos) (funcall foo text state position)
  -         (if ok
  -             (values t `(:whatever ,x) s pos)
  -             (values nil nil state position))))
  -
  -(or foo bar)
  -
  -  => (multiple-value-bind (ok r s pos)
  -         (foo text state position)
  -       (if ok
  -           (values t r s pos) ;; success
  -           (multiple-value-bind (ok r s pos)
  -               (bar text state position)
  -             (if ok
  -                 (values t r s pos) ;; success
  -                 (values nil nil state position)))))
  -
  -
  -
  -(STATE :name) (except in SETF, et al. forms) access the named
  -value in the current (i.e. passed in) state.
  -
  -(SETF (STATE :name) ...) modify the named value in the new state.
  -(INCF (STATE :name) ...) modify the named value in the new state.
  -(DECF (STATE :name) ...) modify the named value in the new state.
  -
  -|#
  -
  -(defun compile-parser (p)
  +(defmacro defparser (name (&rest args) &body body)
  +  (compile-parser name args body))
  +
  +(defun decompile (p)
  +  "Mostly for debugging. Essentially the same as macro expanding."
     (destructuring-bind (defparser name (&rest args) &rest body) p
       (declare (ignore defparser))
  -    (%compile-parser name args body)))
  -
  -(defun %compile-parser (name args body)
  +    (compile-parser name args body)))
  +
  +
  +(defun compile-parser (name arglist body)
     (let* ((productions (mapcar #'normalize-production body))
            (names (mapcar #'caar productions)))
  -    `(defun ,name (text position ,@args)
  -       (flet (,@(loop for p in productions collect
  -                    (destructuring-bind ((name &rest args) &rest body) p
  -                      `(,name (,@args text state position)
  -                              ,(compile-progn body 'text 'state 'position names (gensym "R"))))))
  -         (,(first names)
  -           text
  -           (list ,@(mapcar #'(lambda (x) `(cons ',x ,x)) args))
  -           position)))))
  +    (multiple-value-bind (args state-vars) (extract-state-variables arglist)
  +      (with-gensyms (txt pos)
  +        `(defun ,name (,txt ,pos ,@args)
  +
  +           (let (,@state-vars)
  +             (labels (,@(loop for p in productions collect
  +                           (with-gensyms (txt pos)
  +                             (destructuring-bind ((name &rest args) &rest body) p
  +                               `(,name (,@args ,txt ,pos)
  +                                       ,(compile-progn body txt pos names (gensym "R")))))))
  +               (,(first names) ,txt ,pos))))))))
  +
  +(defun extract-state-variables (args)
  +  (let ((state (member `&state args)))
  +    (if state
  +        (values (ldiff args state) (cdr state))
  +        (values args nil))))
   
   (defun normalize-production (p)
     (destructuring-bind (x &rest body) p
  -    `(,(typecase  x
  +    `(,(typecase x
            (cons x)
            (symbol (list x)))
          ,@body)))
  
positive.code:      (setf (get ',name 'parser-function) t)
       (defun ,name (,@args) ,@body)))
  
  (defparserfun any-char (text state position)
    "Match a single character. Succeeds everywhere except at the EOF."
    (if (< position (length text))
        (values t (char text position) state (1+ position))
        (values nil nil state position)))
  
  (defparserfun try (p text state position)
    "Attempt to parse using p, moving forward if it succeeds. However if
  it fails, it does not consume any input."
    (multiple-value-bind (ok r ns np) (funcall p text state position)
      (if ok
          (values t r ns np)
          (values nil nil state position))))
  
  (defparserfun many (p text state position)
    "Match P as many times as possible. Always succeeds as zero is an
  acceptable number of times to match."
    (loop with r = nil
       while t do
         (multiple-value-bind (ok result new-state new-position)
             (funcall p text state position)
           (cond
             (ok
              (push r result)
              (setf state new-state)
              (setf position new-position))
             (t
              (return (values t (nreverse r) state position)))))))
  
  (defparserfun many1 (p text state position)
    "Match P as many times as possible but at least once."
    (multiple-value-bind (ok r s p) (many p text state position)
      (if (and ok r)
          (values t r s p)
          (values nil nil state position))))
  
  (defparserfun not-followed-by (p text state position)
    "Match only if not followed by P."
    (multiple-value-bind (ok r s pos)
        (funcall p text state position)
      (declare (ignore r s pos))
      (values (not ok) text state position)))
  
  (defparserfun optional (p text state position)
    "Match P if we can. Doesn't return anything. Only fails if P
  consumes input before failing."
    (multiple-value-bind (ok r s pos) (funcall p text state position)
      (declare (ignore ok r))
      (values (= pos position) t nil s pos)))
  
  (defparserfun counted (n p text state position)
    "Match P N times."
    (if (zerop n)
        (values text state position)
        (multiple-value-bind (ok r s pos) (funcall p text state position)
          (declare (ignore r))
          (if ok
              (counted (1- n) p text s pos)
              (values nil nil state position)))))
  
  (defparserfun look-ahead (p text state position)
    (multiple-value-bind (ok r s pos) (funcall p text state position)
      (declare (ignore r s pos))
      (if ok
          (values t nil state position)
          (values nil nil state position))))
  
negative.code:                 ,(compile-expression else names))))
  
          ((stringp exp)
           (thunk (compile-string exp text position)))
  
          ((characterp exp)
           (thunk (compile-character exp text position)))
  
          (t exp)))))
  
  (defun compile-string (str text position)
    `(matching ,str ,(length str) ,text ,position))
  
  (defun compile-character (char text position)
    `(matching-char ,char ,text ,position))
  
  (defun matching (s len text position)
    (let* ((end (+ len position))
           (ok (if (<= end (length text)) (string= s text :start2 position :end2 end))))
      (if ok
          (good s end)
          (bad position))))
  
  (defun matching-char (c text position)
    (if (< position (length text))
        (if (char= c (char text position))
            (good c (1+ position))
            (bad position))
        (bad position)))
  
  
  (defun compile-match (parser txt p)
    `(funcall ,parser ,txt ,p))
  
  (defun compile-parser-call (exp names txt p)
    (destructuring-bind (name &rest args) (rewrite-form exp names)
      (flet ((comp (x) (compile-expression x names)))
        `(,name ,@(mapcar #'comp args) ,txt ,p))))
  
  (defun rewrite-form (form names)
    "Rewrite bare symbols naming parser productions or parser functions
  