pp1.lisp

;;;; http://bford.info/pub/lang/packrat-icfp02.pdf
;;;; Section 2.4 Packrat Parser
;;;;
;;;; Additive  <- Multitive '+' Additive | Multitive
;;;; Multitive <- Primary '*' Multitive | Primary
;;;; Primary   <- '(' Additive ')' | Decimal
;;;; Decimal   <- '0' | ... | '9'


(defpackage pp1
  (:use :cl))
(in-package pp1)

(defmacro lazy (expr)
  (let ((r (gensym)))
    `(let ((,r nil))
       (lambda ()
         (unless ,r
           (setf ,r (list ,expr)))
         (car ,r)))))

(defun force (lazy)
  (funcall lazy))

(defstruct derivs
  additive multitive primary decimal char)

(defun dv-additive (d) (force (derivs-additive d)))
(defun dv-multitive (d) (force (derivs-multitive d)))
(defun dv-primary (d) (force (derivs-primary d)))
(defun dv-decimal (d) (force (derivs-decimal d)))
(defun dv-char (d) (force (derivs-char d)))

(defstruct result parsed value remaining)

(defun parsed (value remaining) (make-result :parsed t :value value :remaining remaining))
(defun no-parse () (make-result :parsed nil))
(defun is-parsed (result) (result-parsed result))

(defun p-additive (d)
  (labels ((alt1 ()
             (let ((r (dv-multitive d)))
               (cond ((is-parsed r)
                      (let* ((d1 (result-remaining r))
                             (r1 (dv-char d1)))
                        (cond ((and (is-parsed r1)
                                    (equal #\+ (result-value r1)))
                               (let* ((d2 (result-remaining r1))
                                      (r2 (dv-additive d2)))
                                 (cond ((is-parsed r2)
                                        (parsed (+ (result-value r) (result-value r2))
                                                (result-remaining r2)))
                                       (t
                                        (alt2)))))
                              (t
                               (alt2)))))
                     (t
                      (alt2)))))
           (alt2 ()
             (dv-multitive d)))
    (alt1)))

(defun p-multitive (d)
  (labels ((alt1 ()
             (let ((r (dv-primary d)))
               (cond ((is-parsed r)
                      (let* ((d1 (result-remaining r))
                             (r1 (dv-char d1)))
                        (cond ((and (is-parsed r1)
                                    (equal #\* (result-value r1)))
                               (let* ((d2 (result-remaining r1))
                                      (r2 (dv-additive d2)))
                                 (cond ((is-parsed r2)
                                        (parsed (* (result-value r) (result-value r2))
                                                (result-remaining r2)))
                                       (t
                                        (alt2)))))
                              (t
                               (alt2)))))
                     (t
                      (alt2)))))
           (alt2 ()
             (dv-primary d)))
    (alt1)))

(defun p-primary (d)
  (labels ((alt1 ()
             (let ((r (dv-char d)))
               (cond ((and (is-parsed r)
                           (equal #\( (result-value r)))
                      (let* ((d1 (result-remaining r))
                             (r1 (dv-additive d1)))
                        (cond ((is-parsed r1)
                               (let* ((d2 (result-remaining r1))
                                      (r2 (dv-char d2)))
                                 (cond ((and (is-parsed r2)
                                             (equal #\) (result-value r2)))
                                        (parsed (result-value r1) (result-remaining r2)))
                                       (t
                                        (alt2)))))
                              (t
                               (alt2)))))
                     (t
                      (alt2)))))
           (alt2 ()
             (dv-decimal d)))
    (alt1)))

(defun p-decimal (d)
  (let ((r (dv-char d)))
    (cond ((and (is-parsed r)
                (position (result-value r) "0123456789"))
           (let ((v (- (char-code (result-value r)) #.(char-code #\0))))
             (parsed v (result-remaining r))))
          (t
           (no-parse)))))

(defun deriv (s)
  (etypecase s
    (string (deriv (coerce s 'list)))
    (list
     (let ((d (make-derivs)))
       (setf (derivs-additive d) (lazy (p-additive d))
             (derivs-multitive d) (lazy (p-multitive d))
             (derivs-primary d) (lazy (p-primary d))
             (derivs-decimal d) (lazy (p-decimal d))
             (derivs-char d) (lazy (if (car s)
                                       (parsed (car s) (deriv (cdr s)))
                                       (no-parse))))
       d))))

(defun parse (s)
  (let ((r (p-additive (deriv s))))
    (and (is-parsed r) (result-value r))))