LISP implementation of a non-deterministic recursive-descent parser

Like parsers in general, this parser combines the following functions:

1. Tokenisation, lexical analysis: identification of the vocabulary items.
   Here, the vocabulary items are already clearly distinguished as list members, so no tokenisation step aside from querying membership of the terminal vocabulary is needed.
2. Recognition: derivation of the input string using the rules.
   The strategy is top-down, left-right, and non-deterministic.
3. Parsing: construction of a parse tree (structural description).
   In this parser, the parse tree construction step is simultaneous with the recognition derivation process. The non-terminal symbol stack (goal stack, active node) does not contain only the non-terminal symbols but also the rules, which are used as templates for constructing the parse tree. The sub-trees of the parse tree are constructed bottom-up whenever a constituent has been completely parsed, and collected in a list prefixed to the rule template.

; cf_par2_tdlr_recdesc.lm
; D.Gibbon
; 17 Nov 2001

(define *eg1* '(man saw woman))
(define *eg2* '(man saw woman near man))
(define *eg3* '(the man saw the woman near this man))

(define (pp l)
  (pp-1 l 0)
  #n)

(define (pp-1 l n)
  (cond
    ((null? l)
    	'())
    ((pair? l)
     (display "(")
     (pp-1 (car l) n)
     (pp-2 (cdr l) (+ 3 n))
     (display ")"))
    (#t
     (display l))))

(define (pp-2 l n)
  (cond
    ((null? l)
    	'())
    ((pair? l)
     (nl)
     (spaces n)
     (pp-1 (car l) n)
     (pp-2 (cdr l) n))
    (#t
     (display l))))

(define (spaces n)
  (cond
    ((< n 1)
     n)
    (#t
      (display " ")
      (spaces (- n 1)))))

(define (listprint l n)
  (cond
    ((null? l)
     (nl)
     n)
    (#t
      (nl)
      (pp (car l))
      (listprint (cdr l) (+ n 1)))))

(define (nl)
	(display ##0a))

(define *sdset* '())

(define (ptd input)
(display "Parsing...")
  (set! *sdset* '())
  (ptopdown
    input
    (list
      (list
        '()
        (start-symbol))))
  (display
    (listprint
      (reverse *sdset*)
      0))
  (display " parse(s)")
  #n)

; Main
(define (ptopdown input stack)
  (cond
   ((and
      (paccept
        input
        stack)
      (pterminate
        (car (caar stack)))
      #f)
    #f)

   ((and
      (pair? stack)
      (pair? (cdr stack))
      (inactive? (car stack)))
    (ptopdown
      input
      (attach stack)))

   ((pscan
      input
      (active (car stack)))
    (ptopdown
      (cdr input)
      (shift input stack)))

   ((predict?
   	  input
       (active (car stack)))
    (pstore
      input
      stack
      (nprod
        (car
          (active (car stack))))))
   (#t #f)))
        
(define (active node)
   (cdr node))

(define (inactive? node)
  (null? (cdr node)))

(define (paccept input stack)
  (and
    (null? input)
    (inactive? (car stack))
    (null? (cdr stack))))

(define (pterminate node)
  (set!
    *sdset*
    (cons node *sdset*)))

(define (attach stack)
  (cons
    (cons
      (append
        (car (cadr stack))
        (list (caar stack)))
      (cddr (cadr stack)))
    (cddr stack)))

(define (pscan input stack)
  (and
    (pair? input)
    (pair? stack)
    (terminal? (car stack))
    (lexicon
      (car stack)
      (car input))))

(define (shift input stack)
  (cons
    (list
      (list
        (car (active (car stack)))
        (car input)))
    stack))

(define (predict? input stack)
  (and
    (pair? input)
    (pair? stack)
    (nonterminal? (car stack))))

(define (pstore input stack expansions)
  (cond
    ((pair? expansions)
     (or
       (ptopdown
         input
         (cons
           (car expansions)
           stack))
       (pstore
         input
         stack
         (cdr expansions))))
     (#t #f)))

(define (nprod symbol)
  (nprod-1
    (list symbol)
    (productions symbol)))


(define (nprod-1 mother expansions)
  (cond
    ((pair? expansions)
     (cons
       (cons
         mother
         (car expansions))
       (nprod-1
         mother
         (cdr expansions))))
    (#t '())