Simple generator of recursive descent parsers in common lisp

parser.lisp

;; helper functions
(defun mklist (obj)
  "Ensure obj is a list"
  (if (listp obj) obj (list obj)))

(defmacro o (&rest fs)
  "Macro for composition of functions. Takes a list of functions and produces
   a closure as expected:

   (o identity (- 12) 1+) => (lambda (&rest args) (identity (- 12 (1+ ,@args))))
   "
  `(lambda (&rest args)
     ,(reduce #'(lambda (acc f) `(,@(mklist f) (,@acc)))
              (reverse fs)
              :initial-value '(apply #'identity args))))

(defun flatten (ls)
  "Flatten a list"
  (mapcan #'(lambda (x) (if (atom x) (mklist x) (flatten x))) ls))

;; implementation
(defparameter *grammar* '((E  ::= (L EE))
                          (EE ::= (+ L EE) (- L EE) epsilon)
                          (L  ::= (F LL))
                          (LL ::= (* F LL) (/ F LL) epsilon)
                          (F  ::= ([ E ]) float (- float) constant)))
(defparameter *tokens* NIL)

(defun nonterminalp (sym)
  "Check if given symbol is a nonterminal based on current *grammar*"
  (assoc sym *grammar*))

(defun expansions (nonterminal)
  "Generate all expansions that can be generated from a nonterminal"
  (rest (rest (nonterminalp nonterminal))))

(defun terminals-for-nonterminal (nonterminal)
  "Generate all terminals which determine nonterminal's expansion"
  (labels ((terminals-for-rules (rules)
             (let ((initial-guess (mapcar (o car mklist) rules)))
               (mapcar #'(lambda (first-element)
                           (if (nonterminalp first-element)
                             (terminals-for-rules (expansions first-element))
                             first-element))
                       initial-guess))))
    (mapcar (o flatten terminals-for-rules list) (expansions nonterminal))))

(defun nonterminal->parse-rule (nonterminal)
  "Construct a rule for parsing given nonterminal"
  (labels ((rule-for-symbol (sym)
             "Construct different parse rules based on whether or not given symbol is a nonterminal or a terminal"
             (if (nonterminalp sym)
               `(check-nonterminal ',sym)
               `(equal (pop *tokens*) ',sym)))
           (rules-for-expansion (expansion)
             "Join together all the parsing rules for every symbol in current expansion"
             `(and ,@(mapcar #'rule-for-symbol expansion))))
    (let* ((expansions (expansions nonterminal))
           (terminals (terminals-for-nonterminal nonterminal))
           (has-epsilon (not (null (member '(epsilon) terminals :test #'equalp)))))
      `(cond ,@(mapcar #'(lambda (terminals expansion)
                           `((member (first *tokens*) ',terminals) ,(rules-for-expansion (mklist expansion))))
                       terminals expansions)
             (T ,has-epsilon)))))

(defmacro eval-grammar ()
  "Construct appropriate check-nonterminal methods for every nonterminal"
  `(progn 
     ,@(mapcar #'(lambda (rule)
                   `(defmethod check-nonterminal ((nonterminal (eql ',(car rule))))
                      ,(nonterminal->parse-rule (car rule))))
               *grammar*)))

(defun parse (grammar tokens)
  "Parse tokens based on grammar and return T if tokens are syntactically ok,
   otherwise return NIL and remaining tokens"
  (let ((*grammar* grammar)
        (*tokens* tokens))
    (eval-grammar)
    (or (and (check-nonterminal (caar *grammar*)) (null *tokens*))
        (values NIL *tokens*))))

; usage: (parse *grammar* '(float - float * [ float + float ] )