br-parser-tools/collects/parser-tools/private-yacc/parser-builder.ss

#cs
(module parser-builder mzscheme
  
  (require "input-file-parser.ss"
           "parser-actions.ss"
           "grammar.ss"
           "table.ss"
           (lib "class.ss"))
  
  (provide build-parser)
  
  (define (strip so)
    (syntax-local-introduce
     (datum->syntax-object
      #f
      (syntax-object->datum so)
      so
      so)))
  
  (define (fix-check-syntax start terms prods precs ends)
    (syntax-case prods ()
      ((_ (bind ((bound ...) x ...) ...) ...)
       (let ((binds (syntax->list (syntax (bind ...))))
             (bounds (cons start 
                           (apply 
                            append 
                            (map syntax->list 
                                 (apply 
                                  append 
                                  (map syntax->list 
                                       (syntax->list (syntax (((bound ...) ...) ...)))))))))
             (terms (get-term-list terms))
             (precs (if precs
                        (syntax-case precs ()
                          ((_ (__ term ...) ...)
                           (apply append (map syntax->list (syntax->list (syntax ((term ...) ...)))))))
                        null)))
         `(if #f (let ,(map (lambda (bind)
                              `(,(strip bind) void))
                            (append terms binds))
                   (void ,@(append ends precs (map strip bounds)))))))))
  
  (define (build-parser filename src-pos suppress input-terms start end assocs prods runtime)
    (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
           (table (build-table grammar filename suppress))
           (num-non-terms (send grammar get-num-non-terms))
           (token-code
            `(let ((ht (make-hash-table)))
               (begin
                 ,@(map (lambda (term)
                          `(hash-table-put! ht 
                                            ',(gram-sym-symbol term)
                                            ,(+ num-non-terms (gram-sym-index term))))
                        (send grammar get-terms))
                 ht)))
           (actions-code
            `(vector ,@(map prod-action (send grammar get-prods)))))
      (let loop ((i 1))
        (if (< i (vector-length table))
            (let ((a (vector-ref table i)))
              (vector-set! table i (cond
                                     ((accept? a) 'accept)
                                     ((shift? a) (- (shift-state a)))
                                     ((reduce? a) (vector (reduce-prod-num a)
                                                          (reduce-lhs-num a)
                                                          (reduce-rhs-length a)))
                                     (else a)))
              (loop (add1 i)))))
    (values table
            token-code
            actions-code
            (fix-check-syntax start input-terms prods assocs end))))
      
  )