LISP implementation of a non-deterministic backtracking left-corner context-free recogniser

The left-corner parsing strategy combines the shift-reduce bottom-up strategy for the first item in a constituent (i.e. on the right hand side of a rule) with a top-down strategy for the following items in the constituent. Consequently, in addition to the shift and reduce functions of the bottom-up recogniser it requires an expand and complete strategy from the top-down recogniser.

; cf_lcr.lm
; Original program: lcr.lsp
; D.Gibbon
; 10 April 1988, 16 Nov 2001
; LISP2 class material

; requires grammar

; The *count* global variable maintains the number of analyses

(define *count* 0)

(define (lcr-init input)
  (set! *count* 0)
  (lcr input '())
  *count*)

(define (lcr input stack)
(cond
; accept
  ((and
      (null? input)
      (pair? stack)
      (equal? stack '(s))
      (set! *count* (+ 1 *count*))
      )
    #f)
; no accept, more in, stack empty or list pair: shift
  ((and
      (pair? input)
      (or
        (null? stack)
        (and
          (pair? stack)
          (pair? (car stack))
          (pair? (cdar stack)))))
   (lcr
     (cdr input)
     (cons
       (category (car input))
       stack)))
; top stack singleton: extract
  ((and
     (pair? stack)
     (pair? (car stack))
     (null? (cdar stack)))
   (lcr
     input
     (cons
       (caar stack)
       (cdr stack))))
; match top stack first rule: reduce
  ((and
     (pair? stack)
     (symbol? (car stack))
     (pair? (cdr stack))
     (pair? (cadr stack))
     (symbol? (caadr stack))
     (equal?
       (car stack)
       (caadr stack)))
   (lcr
     input
     (cons
       (cdadr stack)
       (cddr stack))))
; top stack sym, rest no reduce: rule in
  ((and
     (pair? stack)
     (symbol? (car stack))
     (or
       (null? (cdr stack))
       (and
         (pair? (cadr stack))
         (symbol? (caadr stack)))))
   (lcr-expand
     input
     (car stack)
     (cdr stack)
     (lcr-productions
       (car stack)
       (productions))))
  (#t #f)))


(define (lcr-expand input first rest rules)
(define tmp '())
(cond
  ((null? rules)
    #f)
  ((set!
      tmp
      (lcr
        input
        (cons
          first
          (cons
            (car rules)
            rest))))
    tmp)
  (#t
    (lcr-expand
       input
       first
       rest
       (cdr rules)))))

(define (lcr-productions corner rules)
(cond
  ((null? rules)
    '())
  ((and
     (pair? rules)
     (pair? (car rules))
     (pair? (cdar rules))
     (equal?
       corner
       (cadar rules)))
   (cons
     (append
       (cdar rules)
       (list (caar rules)))
     (lcr-productions
       corner
       (cdr rules))))
  (#t
    (lcr-productions
      corner
      (cdr rules)))))